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), NSD1, NSD2, NDD
2500 C  extension to standard particle data interface (PHOJET specific)
2501       INTEGER IMPART,IPHIST,ICOLOR
2502       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
2503 C  global event kinematics and particle IDs
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       PARAMETER (NMXHEP=4000)
11840       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
11841      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
11842      &                VHEP(4,NMXHEP), NSD1, NSD2, NDD
11843
11844 C  model switches and parameters
11845       CHARACTER*8 MDLNA
11846       INTEGER ISWMDL,IPAMDL
11847       DOUBLE PRECISION PARMDL
11848       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11849 C  table of particle indices for recursive PHOJET calls
11850       INTEGER MAXIPX
11851       PARAMETER ( MAXIPX = 100 )
11852       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11853       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11854      &                IPOIX1,IPOIX2,IPOIX3
11855 C  general process information
11856       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11857       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11858 C  global event kinematics and particle IDs
11859       INTEGER IFPAP,IFPAB
11860       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11861       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11862 C  cross sections
11863       INTEGER IPFIL,IFAFIL,IFBFIL
11864       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11865      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11866      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11867      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11868      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11869       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11870      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11871      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11872      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11873      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11874      &                IPFIL,IFAFIL,IFBFIL
11875 C  event weights and generated cross section
11876       INTEGER IPOWGC,ISWCUT,IVWGHT
11877       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11878       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11879      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11880 C  internal rejection counters
11881       INTEGER NMXJ
11882       PARAMETER (NMXJ=60)
11883       CHARACTER*10 REJTIT
11884       INTEGER IFAIL
11885       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11886
11887       IREJ = 0
11888 C  clear event statistics
11889       KSPOM = 0
11890       KHPOM = 0
11891       KSREG = 0
11892       KHDIR = 0
11893       KSTRG = 0
11894       KHTRG = 0
11895       KSLOO = 0
11896       KHLOO = 0
11897       KHARD = 0
11898       KSOFT = 0
11899       KSDPO = 0
11900       KHDPO = 0
11901
11902 C-------------------------------------------------------------------
11903 C  nondiffractive resolved processes
11904
11905       IF(IPROC.EQ.1) THEN
11906 C  sample number of interactions
11907  555    CONTINUE
11908         IINT = 0
11909         IP   = 1
11910 C  generate only hard events
11911         IF(ISWMDL(2).EQ.0) THEN
11912           MHPOM = 1
11913           MSPOM = 0
11914           MSREG = 0
11915           MHDIR = 0
11916           HSWGHT(1) = 1.D0
11917         ELSE
11918 C  minimum bias events
11919           IPOWGC(1) = 0
11920  10       CONTINUE
11921           CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
11922           IPOWGC(1) = IPOWGC(1)+1
11923           MINT = 0
11924           MHDIR = 0
11925           MSTRG = 0
11926           MSLOO = 0
11927 C
11928 C  resolved soft processes: pomeron and reggeon
11929           MSPOM = IINT
11930           MSREG = JINT
11931 C  resolved hard process: hard pomeron
11932           MHPOM = KINT
11933 C  resolved absorptive corrections
11934           MPTRI = 0
11935           MPLOO = 0
11936 C  restrictions given by user
11937           IF(MSPOM.LT.ISWCUT(1)) GOTO 10
11938           IF(MSREG.LT.ISWCUT(2)) GOTO 10
11939           IF(MHPOM.LT.ISWCUT(3)) GOTO 10
11940           HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
11941 C  ----------------------------
11942           IF(ISWMDL(15).EQ.0) THEN
11943             MHPOM = 0
11944             IF(MSREG.GT.0) THEN
11945               MSPOM = 0
11946               MSREG = 1
11947             ELSE
11948               MSPOM = 1
11949               MSREG = 0
11950             ENDIF
11951           ELSE IF(ISWMDL(15).EQ.1) THEN
11952             IF(MHPOM.GT.0) THEN
11953               MHPOM = 1
11954               MSPOM = 0
11955               MSREG = 0
11956             ELSE IF(MSPOM.GT.0) THEN
11957               MSPOM = 1
11958               MSREG = 0
11959             ELSE
11960               MSREG = 1
11961             ENDIF
11962           ELSE IF(ISWMDL(15).EQ.2) THEN
11963             MHPOM = MIN(1,MHPOM)
11964           ELSE IF(ISWMDL(15).EQ.3) THEN
11965             MSPOM = MIN(1,MSPOM)
11966           ENDIF
11967         ENDIF
11968 C  ----------------------------
11969
11970 C  statistics
11971         ISPS = ISPS+MSPOM
11972         IHPS = IHPS+MHPOM
11973         ISRS = ISRS+MSREG
11974         ISTS = ISTS+MSTRG
11975         ISLS = ISLS+MSLOO
11976
11977         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
11978      &    'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
11979      &    KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
11980
11981         ITRY2 = 0
11982  50     CONTINUE
11983         ITRY2 = ITRY2+1
11984         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11985         KSPOM = MSPOM
11986         KSREG = MSREG
11987         KHPOM = MHPOM
11988         KHDIR = MHDIR
11989         KSTRG = MPTRI
11990         KSLOO = MPLOO
11991
11992         CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
11993         IF(IREJ.NE.0) THEN
11994           IF(IREJ.EQ.50) RETURN
11995           IF(IDEB(3).GE.2) THEN
11996             WRITE(LO,'(/1X,A,I5)')
11997      &        'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
11998             CALL PHO_PREVNT(-1)
11999           ENDIF
12000           RETURN
12001         ENDIF
12002         IF(MHPOM.GT.0) THEN
12003           IDNODF = 3
12004         ELSE IF(MSPOM.GT.0) THEN
12005           IDNODF = 2
12006         ELSE
12007           IDNODF = 1
12008         ENDIF
12009 C  check of quantum numbers of parton configurations
12010         IF(IDEB(3).GE.0) THEN
12011           CALL PHO_CHECK(1,IREJ)
12012           IF(IREJ.NE.0) GOTO 50
12013         ENDIF
12014 C  sample strings to prepare fragmentation
12015         CALL PHO_STRING(1,IREJ)
12016         IF(IREJ.NE.0) THEN
12017           IF(IREJ.EQ.50) RETURN
12018           IFAIL(30) = IFAIL(30)+1
12019           IF(IDEB(3).GE.2)  THEN
12020             WRITE(LO,'(/1X,A,I5)')
12021      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12022             CALL PHO_PREVNT(-1)
12023           ENDIF
12024           IF(ITRY2.LT.20) GOTO 50
12025           IF(IDEB(3).GE.1) THEN
12026             WRITE(LO,'(/1X,A,I5)')
12027      &        'PHO_PARTON: rejection',ITRY2
12028             CALL PHO_PREVNT(-1)
12029           ENDIF
12030           RETURN
12031         ENDIF
12032
12033 C  statistics
12034         ISPA = ISPA+KSPOM
12035         IHPA = IHPA+KHPOM
12036         ISRA = ISRA+KSREG
12037         ISTA = ISTA+KSTRG
12038         ISLA = ISLA+KSLOO
12039
12040 C-------------------------------------------------------------------
12041 C  elastic scattering / quasi-elastic rho/omega/phi production
12042
12043       ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12044         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12045      &    'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12046
12047 C  DPMJET call with special projectile / target: transform into CMS
12048         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12049      &    CALL PHO_DFWRAP(1,JM1,JM2)
12050
12051         CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12052
12053         IF(IREJ.NE.0) THEN
12054 C  DPMJET call with special projectile / target: clean up
12055           IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12056      &      CALL PHO_DFWRAP(-2,JM1,JM2)
12057           IF(IDEB(3).GE.2) THEN
12058             WRITE(LO,'(/1X,A,I5)')
12059      &        'PHO_PARTON: rejection by PHO_QELAST',IREJ
12060             CALL PHO_PREVNT(-1)
12061           ENDIF
12062           RETURN
12063         ENDIF
12064
12065 C  DPMJET call with special projectile / target: transform back
12066         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12067      &    CALL PHO_DFWRAP(2,JM1,JM2)
12068
12069 C  prepare possible decays
12070         CALL PHO_STRING(1,IREJ)
12071         IF(IREJ.NE.0) THEN
12072           IF(IREJ.EQ.50) RETURN
12073           IFAIL(30) = IFAIL(30)+1
12074           RETURN
12075         ENDIF
12076
12077 C---------------------------------------------------------------------
12078 C  double Pomeron scattering
12079
12080       ELSE IF(IPROC.EQ.4) THEN
12081         MSOFT = 0
12082         MHARD = 0
12083         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12084      &      'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12085         IDPS = IDPS+1
12086         ITRY2 = 0
12087  60     CONTINUE
12088         ITRY2 = ITRY2+1
12089         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12090 C
12091         CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12092         IF(IREJ.NE.0) THEN
12093           IF(IDEB(3).GE.2) THEN
12094             WRITE(LO,'(/1X,A,I5)')
12095      &        'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12096             CALL PHO_PREVNT(-1)
12097           ENDIF
12098           RETURN
12099         ENDIF
12100 C  check of quantum numbers of parton configurations
12101         IF(IDEB(3).GE.0) THEN
12102           CALL PHO_CHECK(1,IREJ)
12103           IF(IREJ.NE.0) GOTO 60
12104         ENDIF
12105 C  sample strings to prepare fragmentation
12106         CALL PHO_STRING(1,IREJ)
12107         IF(IREJ.NE.0) THEN
12108           IF(IREJ.EQ.50) RETURN
12109           IFAIL(30) = IFAIL(30)+1
12110           IF(IDEB(3).GE.2) THEN
12111             WRITE(LO,'(/1X,A,I5)')
12112      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12113             CALL PHO_PREVNT(-1)
12114           ENDIF
12115           IF(ITRY2.LT.10) GOTO 60
12116           WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12117           CALL PHO_PREVNT(-1)
12118           RETURN
12119         ENDIF
12120         IDPA = IDPA+1
12121
12122 C-----------------------------------------------------------------------
12123 C  single / double diffraction dissociation
12124
12125       ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12126         MSOFT = 0
12127         MHARD = 0
12128         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12129      &    'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12130         IF(IPROC.EQ.5) ID1S = ID1S+1
12131         IF(IPROC.EQ.6) ID2S = ID2S+1
12132         IF(IPROC.EQ.7) ID3S = ID3S+1
12133         ITRY2 = 0
12134  70     CONTINUE
12135         ITRY2 = ITRY2+1
12136         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12137         IPAR1 = 1
12138         IPAR2 = 1
12139         IF(IPROC.EQ.5) IPAR2 = 0
12140         IF(IPROC.EQ.6) IPAR1 = 0
12141 C  calculate rapidity gap survival probability
12142         SPROB = 1.D0
12143         IF(ECM.GT.10.D0) THEN
12144           IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12145             IF(SIGTR1(1).LT.1.D-10) THEN
12146               SPROB = 1.D0
12147             ELSE
12148               SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12149             ENDIF
12150           ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12151             IF(SIGTR2(1).LT.1.D-10) THEN
12152               SPROB = 1.D0
12153             ELSE
12154               SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12155             ENDIF
12156           ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12157             IF(SIGLOO.LT.1.D-10) THEN
12158               SPROB = 1.D0
12159             ELSE
12160               SPROB = SIGHDD/SIGLOO
12161             ENDIF
12162           ENDIF
12163         ENDIF
12164 **sr
12165 * temporary patch, r.e. 8.6.99
12166         SPROB = 1.D0
12167 **
12168
12169 C  DPMJET call with special projectile / target: transform into CMS
12170         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12171      &    CALL PHO_DFWRAP(1,JM1,JM2)
12172
12173         CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12174
12175         IF(IREJ.NE.0) THEN
12176 C  DPMJET call with special projectile / target: clean up
12177           IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12178      &      CALL PHO_DFWRAP(-2,JM1,JM2)
12179           IF(IDEB(3).GE.2) THEN
12180             WRITE(LO,'(/1X,A,I5)')
12181      &        'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12182             CALL PHO_PREVNT(-1)
12183           ENDIF
12184           RETURN
12185         ENDIF
12186
12187 C  DPMJET call with special projectile / target: transform back
12188         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12189      &    CALL PHO_DFWRAP(2,JM1,JM2)
12190
12191 C  check of quantum numbers of parton configurations
12192         IF(IDEB(3).GE.0) THEN
12193           CALL PHO_CHECK(1,IREJ)
12194           IF(IREJ.NE.0) GOTO 70
12195         ENDIF
12196 C  sample strings to prepare fragmentation
12197         CALL PHO_STRING(1,IREJ)
12198         IF(IREJ.NE.0) THEN
12199           IF(IREJ.EQ.50) RETURN
12200           IFAIL(30) = IFAIL(30)+1
12201           IF(IDEB(3).GE.2) THEN
12202             WRITE(LO,'(/1X,A,I5)')
12203      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12204             CALL PHO_PREVNT(-1)
12205           ENDIF
12206           IF(ITRY2.LT.10) GOTO 70
12207           WRITE(LO,'(/1X,A,I5)')
12208      &      'PHO_PARTON: rejection',ITRY2
12209           CALL PHO_PREVNT(-1)
12210           RETURN
12211         ENDIF
12212         IF(IPROC.EQ.5) THEN
12213            ID1A = ID1A+1
12214            NSD1 = NSD1 +1
12215            ENDIF
12216         IF(IPROC.EQ.6) THEN
12217            ID2A = ID2A+1
12218            NSD2 = NSD2 + 1
12219         ENDIF
12220         IF(IPROC.EQ.7) THEN
12221            ID3A = ID3A+1
12222            NDD = NDD + 1
12223         ENDIF
12224 C-----------------------------------------------------------------------
12225 C  single / double direct processes
12226
12227       ELSE IF(IPROC.EQ.8) THEN
12228         MSREG = 0
12229         MSPOM = 0
12230         MHPOM = 0
12231         MHDIR = 1
12232         IF(IDEB(3).GE.5) THEN
12233           WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12234         ENDIF
12235         IDIS = IDIS+MHDIR
12236         ITRY2 = 0
12237  80     CONTINUE
12238         ITRY2 = ITRY2+1
12239         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12240         KSPOM = MSPOM
12241         KSREG = MSREG
12242         KHPOM = MHPOM
12243         KHDIR = 4
12244
12245         CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12246         IF(IREJ.NE.0) THEN
12247           IF(IREJ.EQ.50) RETURN
12248           IF(IDEB(3).GE.2) THEN
12249             WRITE(LO,'(/1X,A,I5)')
12250      &        'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12251             CALL PHO_PREVNT(-1)
12252           ENDIF
12253           RETURN
12254         ENDIF
12255         IDNODF = 4
12256 C  check of quantum numbers of parton configurations
12257         IF(IDEB(3).GE.0) THEN
12258           CALL PHO_CHECK(1,IREJ)
12259           IF(IREJ.NE.0) GOTO 80
12260         ENDIF
12261 C  sample strings to prepare fragmentation
12262         CALL PHO_STRING(1,IREJ)
12263         IF(IREJ.NE.0) THEN
12264           IF(IREJ.EQ.50) RETURN
12265           IFAIL(30) = IFAIL(30)+1
12266           IF(IDEB(3).GE.2) THEN
12267             WRITE(LO,'(/1X,A,I5)')
12268      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12269             CALL PHO_PREVNT(-1)
12270           ENDIF
12271           IF(ITRY2.LT.10) GOTO 80
12272           WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12273           CALL PHO_PREVNT(-1)
12274           RETURN
12275         ENDIF
12276         IF(IPROC.EQ.5) THEN
12277            ID1A = ID1A+1
12278            NSD1 = NSD1 +1
12279         ENDIF
12280         IF(IPROC.EQ.6) THEN
12281            ID2A = ID2A+1
12282            NSD2 = NSD2 + 1
12283         ENDIF
12284         IF(IPROC.EQ.7) THEN
12285            ID3A = ID3A+1
12286            NDD = NDD + 1
12287         ENDIF
12288         IDIA = IDIA+MHDIR
12289
12290 C-----------------------------------------------------------------------
12291 C  initialize control statistics
12292
12293       ELSE IF(IPROC.EQ.-1) THEN
12294         CALL PHO_SAMPRB(ECM,-1,0,0,0)
12295         CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12296         CALL PHO_SEAFLA(-1,0,0,DUM)
12297         IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12298      &    CALL PHO_QELAST(-1,1,2,0)
12299         ISPS = 0
12300         ISPA = 0
12301         ISRS = 0
12302         ISRA = 0
12303         IHPS = 0
12304         IHPA = 0
12305         ISTS = 0
12306         ISTA = 0
12307         ISLS = 0
12308         ISLA = 0
12309         ID1S = 0
12310         ID1A = 0
12311         ID2S = 0
12312         ID2A = 0
12313         ID3S = 0
12314         ID3A = 0
12315         IDPS = 0
12316         IDPA = 0
12317         IDIS = 0
12318         IDIA = 0
12319         CALL PHO_STRING(-1,IREJ)
12320         CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12321         RETURN
12322
12323 C-----------------------------------------------------------------------
12324 C  produce statistics summary
12325
12326       ELSE IF(IPROC.EQ.-2) THEN
12327         IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12328         IF(IDEB(3).GE.0) THEN
12329           WRITE(LO,'(/1X,A,/1X,A)')
12330      &      'PHO_PARTON: internal statistics on parton configurations',
12331      &      '--------------------------------------------------------'
12332           WRITE(LO,'(5X,A)') 'process          sampled      accepted'
12333           WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12334           WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12335           WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12336           WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12337           WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12338           WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12339           WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12340           WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12341           WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12342           WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12343         ENDIF
12344         CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12345         IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12346      &    CALL PHO_QELAST(-2,1,2,0)
12347         CALL PHO_STRING(-2,IREJ)
12348         CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12349         CALL PHO_SEAFLA(-2,0,0,DUM)
12350         RETURN
12351       ELSE
12352         WRITE(LO,'(1X,A,I2)')
12353      &    'PARTON:ERROR: unknown process ID ',IPROC
12354         STOP
12355       ENDIF
12356
12357       END
12358
12359 *$ CREATE PHO_MCINI.FOR
12360 *COPY PHO_MCINI
12361 CDECK  ID>, PHO_MCINI
12362       SUBROUTINE PHO_MCINI
12363 C********************************************************************
12364 C
12365 C     initialization of MC event generation
12366 C
12367 C********************************************************************
12368       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12369       SAVE
12370
12371       PARAMETER ( PIMASS =  0.13D0,
12372      &            TINY   =  1.D-10 )
12373
12374 C  input/output channels
12375       INTEGER LI,LO
12376       COMMON /POINOU/ LI,LO
12377 C  event debugging information
12378       INTEGER NMAXD
12379       PARAMETER (NMAXD=100)
12380       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12381      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12382       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12383      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12384 C  model switches and parameters
12385       CHARACTER*8 MDLNA
12386       INTEGER ISWMDL,IPAMDL
12387       DOUBLE PRECISION PARMDL
12388       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12389 C  general process information
12390       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12391       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12392 C  cross sections
12393       INTEGER IPFIL,IFAFIL,IFBFIL
12394       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12395      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12396      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12397      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12398      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12399       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12400      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12401      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12402      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12403      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12404      &                IPFIL,IFAFIL,IFBFIL
12405 C  hard cross sections and MC selection weights
12406       INTEGER Max_pro_2
12407       PARAMETER ( Max_pro_2 = 16 )
12408       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12409      &  MH_acc_1,MH_acc_2
12410       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12411       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12412      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12413      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12414      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12415      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12416 C  interpolation tables for hard cross section and MC selection weights
12417       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12418       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12419       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12420       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12421      &  HQ2a_tab,HQ2b_tab,HEcm_tab
12422       COMMON /POHTAB/
12423      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12424      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12425      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12426      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12427      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12428      &  HEcm_tab(1:Max_tab_E,0:4),
12429      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12430 C  global event kinematics and particle IDs
12431       INTEGER IFPAP,IFPAB
12432       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12433       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12434 C  obsolete cut-off information
12435       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12436       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12437 C  event weights and generated cross section
12438       INTEGER IPOWGC,ISWCUT,IVWGHT
12439       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12440       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12441      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12442 C  cut probability distribution
12443       INTEGER IEETA1,IIMAX,KKMAX
12444       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12445       INTEGER IEEMAX,IMAX,KMAX
12446       REAL PROB
12447       DOUBLE PRECISION EPTAB
12448       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12449      &                IEEMAX,IMAX,KMAX
12450 C  energy-interpolation table
12451       INTEGER IEETA2
12452       PARAMETER ( IEETA2 = 20 )
12453       INTEGER ISIMAX
12454       DOUBLE PRECISION SIGTAB,SIGECM
12455       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12456
12457       CHARACTER*15 PHO_PNAME
12458       DIMENSION ECMF(4)
12459
12460       DATA  XMPOM / 0.766D0 /
12461
12462 C  initialize fragmentation
12463       CALL PHO_FRAINI(ISWMDL(6))
12464
12465 C  reset interpolation tables
12466       DO 50 I=1,4
12467         DO 60 J=1,10
12468           DO 70 K=1,70
12469             SIGTAB(I,K,J) = 0.D0
12470  70       CONTINUE
12471           SIGECM(I,J) = 0.D0
12472  60     CONTINUE
12473  50   CONTINUE
12474
12475 C  max. number of allowed colors (large N expansion)
12476       IC1 = 0
12477       IC2 = 10000
12478       CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12479
12480 C  lower energy limit of initialization
12481       ETABLO = PARMDL(19)
12482       IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12483
12484       WRITE(LO,'(/,1X,A,2F12.1)')
12485      &  'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12486       WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12487      &  'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12488      &  PMASS(1),PVIRT(1)
12489       WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12490      &  'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12491      &  PMASS(2),PVIRT(2)
12492
12493 C  cuts on probabilities of multiple interactions
12494       IMAX = MIN(IPAMDL(32),IIMAX)
12495       KMAX = MIN(IPAMDL(33),KKMAX)
12496       AH = 2.D0*PTCUT(1)/ECM
12497       IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12498       KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12499
12500 C  hard interpolation table
12501       ECMF(1) = ECM
12502       ECMF(2) = 0.9D0*ECMF(1)
12503       ECMF(3) = ECMF(2)
12504       ECMF(4) = ECMF(2)
12505       do k=1,4
12506         IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12507         IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12508         IF(ECMF(k).LT.50.D0)  IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12509         IF(ECMF(k).LT.10.D0)  IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12510       enddo
12511
12512 C  initialization of hard scattering for all channels and cutoffs
12513       IF(HSWCUT(5).GT.PARMDL(36))  CALL PHO_HARMCI(-1,ECMF(1))
12514       I0 = 4
12515       IF(ISWMDL(2).EQ.0) I0 = 1
12516       DO 110 I=I0,1,-1
12517         CALL PHO_HARMCI(I,ECMF(I))
12518  110  CONTINUE
12519
12520 C  dimension of interpolation table of cut probabilities
12521       IEEMAX = MIN(IPAMDL(31),IEETA1)
12522       IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12523       IF(ECM.LT.50.D0)  IEEMAX = MIN(IEEMAX,10)
12524       IF(ECM.LT.10.D0)  IEEMAX = MIN(IEEMAX,5)
12525       ISIMAX = IEEMAX
12526
12527 C  calculate probability distribution
12528       I0 = 4
12529       IFT1 = IFPAP(1)
12530       IFT2 = IFPAP(2)
12531       XMT1 = PMASS(1)
12532       XMT2 = PMASS(2)
12533       XVT1 = PVIRT(1)
12534       XVT2 = PVIRT(2)
12535       IF(ISWMDL(2).EQ.0) I0 = 1
12536       DO 150 IP=I0,1,-1
12537       ECMPRO = ECMF(IP)*1.001D0
12538       IF(IP.EQ.4) THEN
12539         IFPAP(1) = 990
12540         IFPAP(2) = 990
12541         PMASS(1) = XMPOM
12542         PMASS(2) = XMPOM
12543         PVIRT(1) = 0.D0
12544         PVIRT(2) = 0.D0
12545       ELSE IF(IP.EQ.3) THEN
12546         IFPAP(1) = IFT2
12547         IFPAP(2) = 990
12548         PMASS(1) = XMT2
12549         PMASS(2) = XMPOM
12550         PVIRT(1) = XVT2
12551         PVIRT(2) = 0.D0
12552       ELSE IF(IP.EQ.2) THEN
12553         IFPAP(1) = IFT1
12554         IFPAP(2) = 990
12555         PMASS(1) = XMT1
12556         PMASS(2) = XMPOM
12557         PVIRT(1) = XVT1
12558         PVIRT(2) = 0.D0
12559       ELSE
12560         IFPAP(1) = IFT1
12561         IFPAP(2) = IFT2
12562         PMASS(1) = XMT1
12563         PMASS(2) = XMT2
12564         PVIRT(1) = XVT1
12565         PVIRT(2) = XVT2
12566       ENDIF
12567       IF(IEEMAX.GT.1) THEN
12568         IF(IP.EQ.1) THEN
12569           ELMIN = LOG(ETABLO)
12570         ELSE
12571           ELMIN = LOG(2.5D0)
12572         ENDIF
12573         EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12574         DO 100 I=1,IEEMAX
12575           ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12576           CALL PHO_PRBDIS(IP,ECMPRO,I)
12577  100    CONTINUE
12578       ELSE
12579         CALL PHO_PRBDIS(IP,ECMPRO,1)
12580       ENDIF
12581
12582 C  debug output of cross section tables
12583       IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12584       IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12585       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12586      &'Table of total cross sections (mb) for particle combination',IP,
12587      &' Ecm    SIGtot  SIGela  SIGine  SIGqel  SIGsd1  SIGsd2  SIGdd',
12588      &'-------------------------------------------------------------'
12589       DO 200 I=1,IEEMAX
12590         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12591      &    SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12592      &    SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12593      &    SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12594      &    SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12595  200  CONTINUE
12596  201  CONTINUE
12597       IF(IDEB(62).GE.2) THEN
12598       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12599      &'Table of partial x-sections (mb) for particle combination',IP,
12600      &' Ecm    SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL  SIGDDH  SIGCDF',
12601      &'--------------------------------------------------------------'
12602       DO 205 I=1,IEEMAX
12603         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12604      &    SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12605      &    SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12606  205  CONTINUE
12607       ENDIF
12608       IF(IDEB(62).GE.2) THEN
12609       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12610      &'Table of born graph x-sections (mb) for particle combination',IP,
12611      &' Ecm    SIGSVDM SIGHRES SIGHDIR SIGTR1  SIGTR2  SIGLOO SIGDPO',
12612      &'-------------------------------------------------------------'
12613       DO 210 I=1,IEEMAX
12614         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12615      &    SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12616      &    SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12617      &    SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12618      &    SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12619      &    +SIGTAB(IP,68,I)
12620  210  CONTINUE
12621       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12622      &'Table of unitarized x-sections (mb) for particle combination',IP,
12623      &' Ecm    SIGSVDM SIGHVDM  SIGTR1  SIGTR2  SIGLOO SIGDPO  SLOPE',
12624      &'-------------------------------------------------------------'
12625       DO 215 I=1,IEEMAX
12626         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12627      &    SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12628      &    SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12629  215  CONTINUE
12630       ENDIF
12631       IF(IDEB(62).GE.1) THEN
12632       WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12633      &'Table of expected average number of cuts in non-diff events:',
12634      &'       for max. number of cuts soft/hard:',IMAX,KMAX,
12635      &' Ecm   PTCUT   SIGNDF   POM-S   POM-H   REG-S',
12636      &'---------------------------------------------'
12637       DO 220 I=1,IEEMAX
12638         WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12639      &    SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12640      &    SIGTAB(IP,76,I)
12641  220  CONTINUE
12642       IF(IP.EQ.1) THEN
12643         WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12644      &  'Table of rapidity gap survival probability (high-mass diff.):',
12645      &  ' Ecm    Spro-sd1     Spro-sd2    Spro-dd    Spro-cd',
12646      &  '---------------------------------------------------'
12647         DO 230 I=1,IEEMAX
12648           IF(SIGECM(IP,I).GT.10.D0) THEN
12649             SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12650      &               -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12651             SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12652      &               -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12653             SPRDD  = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12654      &               +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12655      &               +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12656             SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12657      &               +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12658             WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12659      &        SPRSD1,SPRSD2,SPRDD,SPRCDF
12660           ENDIF
12661  230    CONTINUE
12662       ENDIF
12663       ENDIF
12664       ENDIF
12665  150  CONTINUE
12666
12667 C  simulate only hard scatterings
12668       IF(ISWMDL(2).EQ.0) THEN
12669         WRITE(LO,'(2(/1X,A))')
12670      &    'WARNING: generation of hard scatterings only!',
12671      &    '============================================='
12672         DO 151 I=2,7
12673           IPRON(I,1) = 0
12674  151    CONTINUE
12675         DO 152 K=2,4
12676           DO 153 I=1,15
12677             IPRON(I,K) = 0
12678  153      CONTINUE
12679  152    CONTINUE
12680         SIGGEN(4) = 0.D0
12681         DO 160 I=1,IEEMAX
12682           SIGMAX = 0.D0
12683           IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12684           IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12685           IF(SIGMAX.GT.SIGGEN(4)) THEN
12686             ISIGM = I
12687             SIGGEN(4) = SIGMAX
12688           ENDIF
12689  160    CONTINUE
12690       ELSE
12691         WRITE(LO,'(2(/1X,A))')
12692      &    'activated processes, cross section',
12693      &    '----------------------------------'
12694         WRITE(LO,'(5X,A,I3,2X,3I3)')
12695      &    '  nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12696         WRITE(LO,'(5X,A,I3,2X,3I3)')
12697      &    '            elastic scattering',(IPRON(2,K),K=1,4)
12698         WRITE(LO,'(5X,A,I3,2X,3I3)')
12699      &    'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12700         WRITE(LO,'(5X,A,I3,2X,3I3)')
12701      &    '      double pomeron processes',(IPRON(4,K),K=1,4)
12702         WRITE(LO,'(5X,A,I3,2X,3I3)')
12703      &    ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12704         WRITE(LO,'(5X,A,I3,2X,3I3)')
12705      &    ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12706         WRITE(LO,'(5X,A,I3,2X,3I3)')
12707      &    '    double diffract. processes',(IPRON(7,K),K=1,4)
12708         WRITE(LO,'(5X,A,I3,2X,3I3)')
12709      &    '       direct photon processes',(IPRON(8,K),K=1,4)
12710
12711 C  calculate effective cross section
12712         SIGGEN(4) = 0.D0
12713         DO 165 I=1,IEEMAX
12714           CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12715      &                PVIRT(1),PVIRT(2))
12716           SIGMAX = 0.D0
12717           if(iswmdl(2).ge.1) then
12718             IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12719      &        -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12720      &        -SIGLDD-SIGHDD-SIGDIR
12721             IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12722             IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12723             IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12724             IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12725             IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12726             IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12727             IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12728           else
12729             IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12730             IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12731           endif
12732           IF(SIGMAX.GT.SIGGEN(4)) THEN
12733             ISIGM = I
12734             SIGGEN(4) = SIGMAX
12735           ENDIF
12736  165    CONTINUE
12737       ENDIF
12738
12739 C  debug output
12740       IF(SIGGEN(4).LT.1.D-20) THEN
12741         WRITE(LO,'(//1X,A)')
12742      &  'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12743         STOP
12744       ENDIF
12745       WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12746      &  SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12747       WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12748
12749       END
12750
12751 *$ CREATE PHO_REJSTA.FOR
12752 *COPY PHO_REJSTA
12753 CDECK  ID>, PHO_REJSTA
12754       SUBROUTINE PHO_REJSTA(IMODE)
12755 C********************************************************************
12756 C
12757 C     MC rejection counting
12758 C
12759 C     input IMODE    -1   initialization
12760 C                    -2   output of statistics
12761 C
12762 C********************************************************************
12763       IMPLICIT NONE
12764       SAVE
12765
12766 C  input/output channels
12767       INTEGER LI,LO
12768       COMMON /POINOU/ LI,LO
12769 C  event debugging information
12770       INTEGER NMAXD
12771       PARAMETER (NMAXD=100)
12772       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12773      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12774       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12775      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12776 C  internal rejection counters
12777       INTEGER NMXJ
12778       PARAMETER (NMXJ=60)
12779       CHARACTER*10 REJTIT
12780       INTEGER IFAIL
12781       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12782
12783       INTEGER IMODE
12784
12785       INTEGER I
12786
12787 C  initialization
12788       IF(IMODE.EQ.-1) THEN
12789         DO 100 I=1,NMXJ
12790           IFAIL(I) = 0
12791  100    CONTINUE
12792 C
12793         REJTIT(1)  = 'PARTON ALL'
12794         REJTIT(2)  = 'STDPAR ALL'
12795         REJTIT(3)  = 'STDPAR DPO'
12796         REJTIT(4)  = 'POMSCA ALL'
12797         REJTIT(5)  = 'POMSCA INT'
12798         REJTIT(6)  = 'POMSCA KIN'
12799         REJTIT(7)  = 'DIFDIS ALL'
12800         REJTIT(8)  = 'POSPOM ALL'
12801         REJTIT(9)  = 'HRES.DIF.1'
12802         REJTIT(10) = 'HDIR.DIF.1'
12803         REJTIT(11) = 'HRES.DIF.2'
12804         REJTIT(12) = 'HDIR.DIF.2'
12805         REJTIT(13) = 'DIFDIS INT'
12806         REJTIT(14) = 'HADRON SP2'
12807         REJTIT(15) = 'HADRON SP3'
12808         REJTIT(16) = 'HARDIR ALL'
12809         REJTIT(17) = 'HARDIR INT'
12810         REJTIT(18) = 'HARDIR KIN'
12811         REJTIT(19) = 'MCHECK BAR'
12812         REJTIT(20) = 'MCHECK MES'
12813         REJTIT(21) = 'DIF.DISS.1'
12814         REJTIT(22) = 'DIF.DISS.2'
12815         REJTIT(23) = 'STRFRA ALL'
12816         REJTIT(24) = 'MSHELL CHA'
12817         REJTIT(25) = 'PARTPT SOF'
12818         REJTIT(26) = 'PARTPT HAR'
12819         REJTIT(27) = 'INTRINS KT'
12820         REJTIT(28) = 'HACHEK DIR'
12821         REJTIT(29) = 'HACHEK RES'
12822         REJTIT(30) = 'STRING ALL'
12823         REJTIT(31) = 'POMSCA INT'
12824         REJTIT(32) = 'DIFF SLOPE'
12825         REJTIT(33) = 'GLU2QU ALL'
12826         REJTIT(34) = 'MASCOR ALL'
12827         REJTIT(35) = 'PARCOR ALL'
12828         REJTIT(36) = 'MSHELL PAR'
12829         REJTIT(37) = 'MSHELL ALL'
12830         REJTIT(38) = 'POMCOR ALL'
12831         REJTIT(39) = 'DB-POM KIN'
12832         REJTIT(40) = 'DB-POM ALL'
12833         REJTIT(41) = 'SOFTXX ALL'
12834         REJTIT(42) = 'SOFTXX PSP'
12835
12836 C  write output
12837       ELSE IF(IMODE.EQ.-2) THEN
12838         WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12839      &                             '--------------------------------'
12840         DO 300 I=1,NMXJ
12841           IF(IFAIL(I).GT.0)
12842      &      WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12843  300    CONTINUE
12844       ELSE
12845         WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12846       ENDIF
12847
12848       END
12849
12850 *$ CREATE PHO_POSPOM.FOR
12851 *COPY PHO_POSPOM
12852 CDECK  ID>, PHO_POSPOM
12853       SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12854 C***********************************************************************
12855 C
12856 C     registration of one cut pomeron (soft/semihard)
12857 C
12858 C     input:   IP      particle combination the pomeron belongs to
12859 C              IND1,2  position of X values in /POSOFT/
12860 C                      1 corresponds to a valence-pomeron
12861 C              IGEN    production process of mother particles
12862 C              IPOM    pomeron number
12863 C              KCUT    total number of cut pomerons and reggeons
12864 C
12865 C     output:  ISWAP   exchange of x values
12866 C              IND1,2  increased by the number of partons belonging
12867 C                      to the generated pomeron cut
12868 C              IREJ    success/failure
12869 C
12870 C**********************************************************************
12871       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12872       SAVE
12873
12874       PARAMETER ( DEPS   =  1.D-8 )
12875
12876 C  input/output channels
12877       INTEGER LI,LO
12878       COMMON /POINOU/ LI,LO
12879 C  event debugging information
12880       INTEGER NMAXD
12881       PARAMETER (NMAXD=100)
12882       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12883      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12884       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12885      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12886 C  internal rejection counters
12887       INTEGER NMXJ
12888       PARAMETER (NMXJ=60)
12889       CHARACTER*10 REJTIT
12890       INTEGER IFAIL
12891       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12892 C  model switches and parameters
12893       CHARACTER*8 MDLNA
12894       INTEGER ISWMDL,IPAMDL
12895       DOUBLE PRECISION PARMDL
12896       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12897 C  general process information
12898       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12899       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12900 C  global event kinematics and particle IDs
12901       INTEGER IFPAP,IFPAB
12902       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12903       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12904 C  data of c.m. system of Pomeron / Reggeon exchange
12905       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12906       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12907      &                 SIDP,CODP,SIFP,COFP
12908       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12909      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
12910      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
12911 C  obsolete cut-off information
12912       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12913       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12914 C  energy-interpolation table
12915       INTEGER IEETA2
12916       PARAMETER ( IEETA2 = 20 )
12917       INTEGER ISIMAX
12918       DOUBLE PRECISION SIGTAB,SIGECM
12919       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12920 C  light-cone x fractions and c.m. momenta of soft cut string ends
12921       INTEGER MAXSOF
12922       PARAMETER ( MAXSOF = 50 )
12923       INTEGER IJSI2,IJSI1
12924       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12925       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12926      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12927      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
12928 C  standard particle data interface
12929       INTEGER NMXHEP
12930       PARAMETER (NMXHEP=4000)
12931       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
12932       DOUBLE PRECISION PHEP,VHEP
12933       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
12934      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
12935      &                VHEP(4,NMXHEP)
12936 C  extension to standard particle data interface (PHOJET specific)
12937       INTEGER IMPART,IPHIST,ICOLOR
12938       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
12939 C  table of particle indices for recursive PHOJET calls
12940       INTEGER MAXIPX
12941       PARAMETER ( MAXIPX = 100 )
12942       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
12943       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
12944      &                IPOIX1,IPOIX2,IPOIX3
12945
12946       DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
12947
12948       IREJ = 0
12949       ISWAP = 0
12950       JM1 = NPOSP(1)
12951       JM2 = NPOSP(2)
12952       INDX1 = IND1
12953       INDX2 = IND2
12954       EA1 = XS1(IND1)*ECMP/2.D0
12955       EA2 = XS1(IND1+1)*ECMP/2.D0
12956       EB1 = XS2(IND2)*ECMP/2.D0
12957       EB2 = XS2(IND2+1)*ECMP/2.D0
12958       CMASS1 = MIN(EA1,EA2)
12959       CMASS2 = MIN(EB1,EB2)
12960
12961 C  debug output
12962       IF(IDEB(9).GE.20) THEN
12963         WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
12964      &    'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
12965         WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
12966      &    CMASS1,CMASS2
12967       ENDIF
12968
12969 C  flavours
12970       IF(IND1.EQ.1) THEN
12971         CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
12972       ELSE
12973         CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
12974       ENDIF
12975       IF(IND2.EQ.1) THEN
12976         CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
12977       ELSE
12978         CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
12979       ENDIF
12980       DO 75 I=1,4
12981         P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
12982         P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
12983  75   CONTINUE
12984
12985 C  pomeron resolved?
12986       IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
12987 C  find energy for cross section calculation
12988         IF(IPAMDL(16).EQ.2) THEN
12989           ESUB = ECMP
12990         ELSE IF(IPAMDL(16).EQ.3) THEN
12991           IF(IPROCE.EQ.1) THEN
12992             ESUB = ECM
12993           ELSE
12994             ESUB = ECMP
12995           ENDIF
12996         ELSE
12997           ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
12998      &                -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
12999         ENDIF
13000 C  load cross sections from interpolation table
13001         IF(ESUB.LE.SIGECM(IP,1)) THEN
13002           I1 = 1
13003           I2 = 2
13004         ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
13005           DO 50 I=2,ISIMAX
13006             IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
13007  50       CONTINUE
13008  200      CONTINUE
13009           I1 = I-1
13010           I2 = I
13011         ELSE
13012           WRITE(LO,'(/1X,A,2E12.3)')
13013      &      'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
13014           CALL PHO_PREVNT(-1)
13015           I1 = ISIMAX-1
13016           I2 = ISIMAX
13017         ENDIF
13018         FAC2=0.D0
13019         IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
13020      &                    /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
13021         FAC1=1.D0-FAC2
13022 C  calculate weights
13023 *       WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13024 *       WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13025 *       WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13026 *       WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13027 *       WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13028 *       WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13029
13030         WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13031      &          +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13032         WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13033         WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13034         WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13035      &                 +SIGTAB(IP,64,I2))
13036      &          +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13037      &                 +SIGTAB(IP,64,I1))
13038         WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13039      &                 +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13040      &          +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13041      &                 +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13042
13043 C  one-pomeron cut
13044         WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13045 C  central diff. cut
13046         WGX(2) = WGXCDF
13047 C  diff. diss. of particle 1
13048         WGX(3) = WGXHSD(1)
13049 C  diff. diss. of particle 2
13050         WGX(4) = WGXHSD(2)
13051 C  double diff. dissociation
13052         WGX(5) = WGXHDD
13053 C  two-pomeron cut
13054         WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13055
13056 *       IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13057 *         WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13058 *    &      ' unitarity bound reached for ',IP,ESUB,WGX(1)
13059 *         WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13060 *         WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13061 *         WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13062 *       ENDIF
13063
13064         SUM  = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13065
13066 C  selection loop
13067  205    CONTINUE
13068         XI = DT_RNDM(SUM)*SUM
13069         I = 0
13070         SUM = 0.D0
13071  210    CONTINUE
13072           I = I+1
13073           SUM = SUM+WGX(I)
13074         IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13075 C  phase space correction
13076         IF(I.NE.1) THEN
13077           ISAM = 4
13078           IF(I.EQ.6) ISAM = 8
13079           PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13080 *         IF(DT_RNDM(SUM).GT.PACC) I=1
13081           IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13082         ENDIF
13083
13084 C  do not generate diffraction for events with only one cut pomeron
13085         IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13086
13087 C  do not generate recursive calls for remants with
13088 C  diquark-anti-diquark flavour contents
13089         if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13090         if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13091
13092 C  debug output
13093         IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13094      &    'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13095
13096         IF(I.GT.1) THEN
13097 C  second scattering needed
13098           CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13099           CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13100           IDPD1 = IPHO_ID2PDG(IDHA1)
13101           IDPD2 = IPHO_ID2PDG(IDHA2)
13102
13103           if(INDX1.eq.1) then
13104             if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13105      &        IGEN_had = IGEN
13106           else
13107             IGEN_had = -IGEN
13108           endif
13109           CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13110      &      IPOM,IGEN_had,0,0,IPOS1,1)
13111
13112           if(INDX2.eq.1) then
13113             if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13114      &        IGEN_had = IGEN
13115           else
13116             IGEN_had = -IGEN
13117           endif
13118           CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13119      &      IPOM,IGEN_had,0,0,IPOS1,1)
13120
13121           IND1 = IND1+2
13122           IND2 = IND2+2
13123 C  update index
13124           IPOIX2 = IPOIX2+1
13125           IF(IPOIX2.GT.MAXIPX) THEN
13126             WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13127      &        '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13128             IREJ = 1
13129             RETURN
13130           ENDIF
13131           IPORES(IPOIX2) = I+2
13132           IPOPOS(1,IPOIX2) = IPOS1-1
13133           IPOPOS(2,IPOIX2) = IPOS1
13134           RETURN
13135         ENDIF
13136       ENDIF
13137
13138  100  CONTINUE
13139       IF(ISWMDL(12).EQ.0) THEN
13140 C  sample colors
13141         CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13142         CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13143
13144 C  purely gluonic pomeron or sea strings formed by gluons
13145
13146         IF(    ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13147      &     .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13148           IFLA1 = 21
13149           IFLA2 = 21
13150         ENDIF
13151         IF(    ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13152      &     .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13153           IFLB1 = 21
13154           IFLB2 = 21
13155         ENDIF
13156
13157 C  color connection
13158         IF(IFLA1.NE.21) THEN
13159           IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13160      &      .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13161      &      CALL PHO_SWAPI(ICA1,ICD1)
13162         ENDIF
13163         IF(IFLB1.NE.21) THEN
13164           IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13165      &      .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13166      &      CALL PHO_SWAPI(ICB1,ICC1)
13167         ENDIF
13168         ISWAP = 0
13169         IF(ICA1*ICB1.GT.0) THEN
13170           IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13171             IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13172               CALL PHO_SWAPI(IFLA1,IFLA2)
13173               CALL PHO_SWAPI(ICA1,ICD1)
13174             ELSE
13175               CALL PHO_SWAPI(IFLB1,IFLB2)
13176               CALL PHO_SWAPI(ICB1,ICC1)
13177             ENDIF
13178           ELSE IF(IND1.NE.1) THEN
13179             CALL PHO_SWAPI(IFLA1,IFLA2)
13180             CALL PHO_SWAPI(ICA1,ICD1)
13181           ELSE IF(IND2.NE.1) THEN
13182             CALL PHO_SWAPI(IFLB1,IFLB2)
13183             CALL PHO_SWAPI(ICB1,ICC1)
13184           ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13185             IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13186               CALL PHO_SWAPI(IFLA1,IFLA2)
13187               CALL PHO_SWAPI(ICA1,ICD1)
13188             ELSE
13189               CALL PHO_SWAPI(IFLB1,IFLB2)
13190               CALL PHO_SWAPI(ICB1,ICC1)
13191             ENDIF
13192           ELSE IF(IFLA1.EQ.-IFLA2) THEN
13193             CALL PHO_SWAPI(IFLA1,IFLA2)
13194             CALL PHO_SWAPI(ICA1,ICD1)
13195           ELSE IF(IFLB1.EQ.-IFLB2) THEN
13196             CALL PHO_SWAPI(IFLB1,IFLB2)
13197             CALL PHO_SWAPI(ICB1,ICC1)
13198           ELSE
13199             ISWAP = 1
13200             IF(IDEB(9).GE.5) THEN
13201               WRITE(LO,'(1X,A,I12)')
13202      &          'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13203                 WRITE(LO,'(5X,A,4I7)')
13204      &          'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13205               WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13206             ENDIF
13207           ENDIF
13208         ENDIF
13209
13210 C  registration
13211
13212 C  purely gluonic pomeron or sea strings formed by gluons
13213         IF(IFLA1.EQ.21) THEN
13214           CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13215      &      IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13216           IND1 = IND1+2
13217
13218 C  strings formed by quarks
13219         ELSE
13220 C  valence quark labels
13221           IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13222      &       .and.(IDHEP(JM1).NE.990)) THEN
13223             ICA2 = 1
13224             ICD2 = 1
13225           ENDIF
13226 C  registration
13227           CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13228      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13229      &      ICA2,IPOS1,1)
13230           IND1 = IND1+1
13231           CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13232      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13233      &      ICD2,IPOS,1)
13234           IND1 = IND1+1
13235         ENDIF
13236
13237 C  purely gluonic pomeron or sea strings formed by gluons
13238         IF(IFLB1.EQ.21) THEN
13239           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13240      &      IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13241           IND2 = IND2+2
13242
13243 C  strings formed by quarks
13244         ELSE
13245 C  valence quark labels
13246           IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13247      &       .and.(IDHEP(JM2).NE.990)) THEN
13248             ICB2 = 1
13249             ICC2 = 1
13250           ENDIF
13251 C  registration
13252           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13253      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13254      &      ICB2,IPOS,1)
13255           IND2 = IND2+1
13256           CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13257      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13258      &      ICC2,IPOS2,1)
13259           IND2 = IND2+1
13260         ENDIF
13261
13262 C  soft pt assignment
13263         IF(ISWMDL(18).EQ.0) THEN
13264           CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13265           IF(IREJ.NE.0) THEN
13266             IFAIL(25) = IFAIL(25)+1
13267             RETURN
13268           ENDIF
13269         ENDIF
13270       ELSE
13271 *       CALL PHO_BFKL(P1,P2,IPART,IREJ)
13272 *       IF(IREJ.NE.0) RETURN
13273       ENDIF
13274
13275       END
13276
13277 *$ CREATE PHO_HADSP2.FOR
13278 *COPY PHO_HADSP2
13279 CDECK  ID>, PHO_HADSP2
13280       SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13281 C***********************************************************************
13282 C
13283 C     split hadron momentum XMAX into two partons using
13284 C     lower cut-off: AS
13285 C
13286 C     input:   IFLB    compressed particle code of particle to split
13287 C              XS1     sum of x values already selected
13288 C              XMAX    maximal x possible
13289 C
13290 C     output:  XS1     new sum of x values (without first one)
13291 C              XSOFT1  field of selected x values
13292 C
13293 C**********************************************************************
13294       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13295       SAVE
13296
13297       PARAMETER ( DEPS   =  1.D-8 )
13298
13299       DIMENSION XSOFT1(50)
13300
13301 C  input/output channels
13302       INTEGER LI,LO
13303       COMMON /POINOU/ LI,LO
13304 C  event debugging information
13305       INTEGER NMAXD
13306       PARAMETER (NMAXD=100)
13307       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13308      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13309       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13310      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13311 C  internal rejection counters
13312       INTEGER NMXJ
13313       PARAMETER (NMXJ=60)
13314       CHARACTER*10 REJTIT
13315       INTEGER IFAIL
13316       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13317 C  data on most recent hard scattering
13318       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13319       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13320      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13321      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13322       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13323      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13324      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13325      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13326      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13327
13328 C  model exponents
13329       DATA PVMES1 /-0.5D0/
13330       DATA PVMES2 /-0.5D0/
13331       DATA PVBAR1 / 1.5D0/
13332       DATA PVBAR2 /-0.5D0/
13333 C
13334       IREJ = 0
13335       ITMAX = 100
13336 C
13337 C  mesonic particle
13338       IF(ipho_bar3(IFLB,0).EQ.0) THEN
13339         XPOT1 = PVMES1+1.D0
13340         XPOT2 = PVMES2+1.D0
13341 C  baryonic particle
13342       ELSE
13343         XPOT1 = PVBAR1+1.D0
13344         XPOT2 = PVBAR2+1.D0
13345       ENDIF
13346       ITER = 0
13347       XREST= 1.D0-XS1
13348 C  selection loop
13349  100  CONTINUE
13350         ITER = ITER+1
13351         IF(ITER.GE.ITMAX) THEN
13352           IF(IDEB(39).GE.3) THEN
13353             WRITE(LO,'(1X,A,I8)')
13354      &        'PHO_HADSP2: REJECTION (ITER)',ITER
13355             WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13356           ENDIF
13357           IFAIL(14) = IFAIL(14)+1
13358           IREJ = 1
13359           RETURN
13360         ENDIF
13361         ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13362       IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13363       XSS1 = XS1 + ZZ
13364       IF((1.D0-XSS1).LT.AS) GOTO 100
13365 C
13366       XS1 = XSS1
13367       XSOFT1(1) = 1.D0-XSS1
13368       XSOFT1(2) = ZZ
13369 C  debug output
13370       IF(IDEB(39).GE.10) THEN
13371         WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13372         WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS  X1,X2:',
13373      &    XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13374       ENDIF
13375       END
13376
13377 *$ CREATE PHO_HADSP3.FOR
13378 *COPY PHO_HADSP3
13379 CDECK  ID>, PHO_HADSP3
13380       SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13381 C***********************************************************************
13382 C
13383 C     split hadron momentum XMAX into diquark & quark pair
13384 C     using lower cut-off: AS
13385 C
13386 C     input:   IFLB    compressed particle code of particle to split
13387 C              XS1     sum of x values already selected
13388 C              XMAX    maximal x possible
13389 C
13390 C     output:  XS1     new sum of x values
13391 C              XSOFT1  field of selected x values
13392 C
13393 C
13394 C**********************************************************************
13395       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13396       SAVE
13397       PARAMETER ( DEPS   =  1.D-8 )
13398
13399       DIMENSION XSOFT1(50),XSOFT2(50)
13400
13401 C  input/output channels
13402       INTEGER LI,LO
13403       COMMON /POINOU/ LI,LO
13404 C  event debugging information
13405       INTEGER NMAXD
13406       PARAMETER (NMAXD=100)
13407       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13408      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13409       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13410      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13411 C  internal rejection counters
13412       INTEGER NMXJ
13413       PARAMETER (NMXJ=60)
13414       CHARACTER*10 REJTIT
13415       INTEGER IFAIL
13416       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13417 C  data of c.m. system of Pomeron / Reggeon exchange
13418       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13419       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13420      &                 SIDP,CODP,SIFP,COFP
13421       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13422      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
13423      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
13424
13425       DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13426
13427 C  model exponents
13428       DATA PVMES1 /-0.5D0/
13429       DATA PVMES2 /-0.5D0/
13430       DATA PSMES  /-0.99D0/
13431       DATA PVBAR1 / 1.5D0/
13432       DATA PVBAR2 /-0.5D0/
13433       DATA PSBAR  /-0.99D0/
13434 C
13435       IREJ = 0
13436 C
13437 C  determine exponents
13438 C  particle 1
13439 C
13440       XMMIN = 0.3D0/ECMP
13441       XBMIN = 1.6D0/ECMP
13442 C  mesonic particle
13443       IF(ipho_bar3(IFLB,0).EQ.0) THEN
13444         XPOT1(1) = PVMES1
13445         XMIN(1,1)  = XMMIN
13446         XPOT1(2) = PVMES2
13447         XMIN(1,2)  = XMMIN
13448         XPOT1(3) = PSMES
13449         XMIN(1,3)  = XMMIN
13450 C  baryonic particle
13451       ELSE
13452         XPOT1(1) = PVBAR1
13453         XMIN(1,1)  = XBMIN
13454         XPOT1(2) = PVBAR2
13455         XMIN(1,2)  = XMMIN
13456         XPOT1(3) = PSBAR
13457         XMIN(1,3)  = XMMIN
13458       ENDIF
13459 C  particle 2
13460 C  mesonic particle
13461       XPOT2(1) = PVMES1
13462       XMIN(2,1)  = XMMIN
13463       XPOT2(2) = PVMES2
13464       XMIN(2,2)  = XMMIN
13465       XPOT2(3) = PSMES
13466       XMIN(2,3)  = XMMIN
13467 C
13468       XDUM1 = 0.01D0
13469       XDUM2 = 0.99D0
13470       CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13471      &            XSOFT1,XSOFT2,IREJ)
13472 C  rejection?
13473       IF(IREJ.NE.0) THEN
13474         IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13475      &    'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13476         IFAIL(15) = IFAIL(15)+1
13477         IREJ = 1
13478         RETURN
13479       ENDIF
13480 C  debug output
13481       IF(IDEB(74).GE.10) THEN
13482         WRITE(LO,'(1X,A,I6,2E12.4)')
13483      &    'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13484         DO 100 I=1,3
13485           WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13486  100    CONTINUE
13487       ENDIF
13488
13489       END
13490
13491 *$ CREATE PHO_SOFTXX.FOR
13492 *COPY PHO_SOFTXX
13493 CDECK  ID>, PHO_SOFTXX
13494       SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13495      &                  XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13496 C***********************************************************************
13497 C
13498 C    select soft x values
13499 C
13500 C    input:   JM1,JM2    mother particle index in POEVT1
13501 C                        (0  flavour not known before)
13502 C             MSPAR1,2   number of x values to select
13503 C             IVAL1,2    number valence quarks involved in hard
13504 C                        scattering (0,1,2)
13505 C             MSM1,2     minimum number of soft x to get sampled
13506 C             XSUM1,2    sum of all x values samples up this call
13507 C             XMAX1,2    max. x value
13508 C
13509 C    output   XSUM1,2    new sum of x-values sampled
13510 C             XS1,2      field containing sampled x values
13511 C
13512 C    x values of valence partons are first given
13513 C
13514 C***********************************************************************
13515       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13516       SAVE
13517
13518 C  input/output channels
13519       INTEGER LI,LO
13520       COMMON /POINOU/ LI,LO
13521 C  event debugging information
13522       INTEGER NMAXD
13523       PARAMETER (NMAXD=100)
13524       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13525      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13526       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13527      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13528 C  internal rejection counters
13529       INTEGER NMXJ
13530       PARAMETER (NMXJ=60)
13531       CHARACTER*10 REJTIT
13532       INTEGER IFAIL
13533       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13534 C  model switches and parameters
13535       CHARACTER*8 MDLNA
13536       INTEGER ISWMDL,IPAMDL
13537       DOUBLE PRECISION PARMDL
13538       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13539 C  data of c.m. system of Pomeron / Reggeon exchange
13540       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13541       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13542      &                 SIDP,CODP,SIFP,COFP
13543       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13544      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
13545      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
13546 C  standard particle data interface
13547       INTEGER NMXHEP
13548       PARAMETER (NMXHEP=4000)
13549       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13550       DOUBLE PRECISION PHEP,VHEP
13551       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13552      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13553      &                VHEP(4,NMXHEP)
13554 C  extension to standard particle data interface (PHOJET specific)
13555       INTEGER IMPART,IPHIST,ICOLOR
13556       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13557 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
13558       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13559       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13560       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13561      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13562 C  obsolete cut-off information
13563       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13564       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13565 C  data on most recent hard scattering
13566       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13567       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13568      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13569      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13570       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13571      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13572      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13573      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13574      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13575
13576       DIMENSION XS1(*),XS2(*)
13577
13578       INTEGER MAXPOT
13579       PARAMETER ( MAXPOT = 50 )
13580       DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13581
13582       IREJ = 0
13583
13584       MSMAX = MAX(MSPAR1,MSPAR2)
13585       MSMIN = MAX(MSM1,MSM2)
13586       IF(MSMAX.GT.MAXPOT) THEN
13587         WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13588      &    'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13589         IREJ = 1
13590         RETURN
13591       ENDIF
13592 C  determine exponents
13593       IBAR1 = ipho_bar3(JM1,2)
13594       IBAR2 = ipho_bar3(JM2,2)
13595       ISWAP = 0
13596       IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13597 C  meson-baryon scattering (asymmetric sea)
13598       IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13599         PSBAR = PARMDL(53)
13600         PSMES = PARMDL(57)
13601       ELSE
13602         PSBAR = PARMDL(52)
13603         PSMES = PARMDL(56)
13604       ENDIF
13605
13606 C  lower limits for x sampling
13607       XMMINA = 2.D0*PARMDL(157)/ECMP
13608       XBMINA = 2.D0*PARMDL(158)/ECMP
13609       XSMINA = 2.D0*PARMDL(159)/ECMP
13610       XMIN1 = MAX(XSOMIN,AS/XMAX2)
13611       XMIN2 = MAX(XSOMIN,AS/XMAX1)
13612       XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13613       XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13614       XMIN1 = MAX(AS/XMAX2,XMIN1)
13615       XMIN2 = MAX(AS/XMAX1,XMIN2)
13616
13617 C  particle 1
13618       XMMIN1 = MAX(XMIN1,XMMINA)
13619       XBMIN1 = MAX(XMIN1,XBMINA)
13620       XSMIN1 = MAX(XMIN1,XSMINA)
13621 C  mesonic particle
13622       IF(IBAR1.EQ.0) THEN
13623         IF(IHFLS(1).EQ.0) THEN
13624           XPOT1(1) = PARMDL(62)
13625           XMIN(1,1)  = XSMIN1
13626           XPOT1(2) = PARMDL(63)
13627           XMIN(1,2)  = XSMIN1
13628         ELSE
13629           XPOT1(1) = PARMDL(54)
13630           XMIN(1,1)  = XMMIN1
13631           XPOT1(2) = PARMDL(55)
13632           XMIN(1,2)  = XMMIN1
13633         ENDIF
13634         DO 100 I=3-IVAL1,MSMAX
13635           XPOT1(I) = PSMES
13636           XMIN(1,I)  = XSMIN1
13637  100    CONTINUE
13638 C  baryonic particle
13639       ELSE
13640         IF(IHFLS(1).EQ.0) THEN
13641           XPOT1(1) = PARMDL(62)
13642           XMIN(1,1)  = XSMIN1
13643           XPOT1(2) = PARMDL(63)
13644           XMIN(1,2)  = XSMIN1
13645         ELSE
13646           XPOT1(1) = PARMDL(50)
13647           XMIN(1,1)  = XBMIN1
13648           XPOT1(2) = PARMDL(51)
13649           XMIN(1,2)  = XMMIN1
13650         ENDIF
13651         DO 200 I=3-IVAL1,MSMAX
13652           XPOT1(I) = PSBAR
13653           XMIN(1,I)  = XSMIN1
13654  200    CONTINUE
13655       ENDIF
13656
13657 C  particle 2
13658       XMMIN2 = MAX(XMIN2,XMMINA)
13659       XBMIN2 = MAX(XMIN2,XBMINA)
13660       XSMIN2 = MAX(XMIN2,XSMINA)
13661 C  mesonic particle
13662       IF(IBAR2.EQ.0) THEN
13663         IF(IHFLS(2).EQ.0) THEN
13664           XPOT2(1) = PARMDL(62)
13665           XMIN(2,1)  = XSMIN2
13666           XPOT2(2) = PARMDL(63)
13667           XMIN(2,2)  = XSMIN2
13668         ELSE
13669           XPOT2(1) = PARMDL(54)
13670           XMIN(2,1)  = XMMIN2
13671           XPOT2(2) = PARMDL(55)
13672           XMIN(2,2)  = XMMIN2
13673         ENDIF
13674         DO 300 I=3-IVAL2,MSMAX
13675           XPOT2(I) = PSMES
13676           XMIN(2,I)  = XSMIN2
13677  300    CONTINUE
13678 C  baryonic particle
13679       ELSE
13680         IF(IHFLS(2).EQ.0) THEN
13681           XPOT2(1) = PARMDL(62)
13682           XMIN(2,1)  = XSMIN2
13683           XPOT2(2) = PARMDL(63)
13684           XMIN(2,2)  = XSMIN2
13685         ELSE
13686           XPOT2(1) = PARMDL(50)
13687           XMIN(2,1)  = XBMIN2
13688           XPOT2(2) = PARMDL(51)
13689           XMIN(2,2)  = XMMIN2
13690         ENDIF
13691         DO 400 I=3-IVAL2,MSMAX
13692           XPOT2(I) = PSBAR
13693           XMIN(2,I)  = XSMIN2
13694  400    CONTINUE
13695       ENDIF
13696
13697       XSS1 = XSUM1
13698       XSS2 = XSUM2
13699       MSOFT = MSMAX
13700
13701 C  check limits (important for valences)
13702       IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13703       IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13704
13705       XMINS1 = XSS1
13706       IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13707       XMINS2 = XSS2
13708       IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13709       DO 10 I=1,MSOFT
13710         XMINS1 = XMINS1+XMIN(1,I)
13711         XMINS2 = XMINS2+XMIN(2,I)
13712  10   CONTINUE
13713       IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13714
13715 C  try to sample x values
13716       IF(IPAMDL(14).EQ.0) THEN
13717         IF(MSOFT.EQ.2) THEN
13718           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13719      &                XS1,XS2,IREJ)
13720         ELSE IF(MSOFT.LT.5) THEN
13721           CALL PHO_SELSXR(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 IF(IPAMDL(14).EQ.1) THEN
13728         IF(MSOFT.EQ.2) THEN
13729           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13730      &                XS1,XS2,IREJ)
13731         ELSE
13732           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13733      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13734         ENDIF
13735       ELSE IF(IPAMDL(14).EQ.2) THEN
13736         CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13737      &              XMAXP1,XMAXP2,XS1,XS2,IREJ)
13738       ELSE IF(IPAMDL(14).EQ.3) THEN
13739         IF(MSOFT.EQ.2) THEN
13740           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13741      &                XS1,XS2,IREJ)
13742         ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13743           CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13744      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13745         ELSE
13746           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13747      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13748         ENDIF
13749       ELSE
13750         WRITE(LO,'(/,1X,A,I3)')
13751      &    'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13752         STOP
13753       ENDIF
13754       IF(IREJ.NE.0) THEN
13755         IFAIL(41) = IFAIL(41)+1
13756         IF(IDEB(60).GE.2) THEN
13757           WRITE(LO,'(1X,A,I12,4I3)')
13758      &      'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13759      &      KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13760           WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13761      &      XSUM1,XSUM2,XMAX1,XMAX2
13762         ENDIF
13763         RETURN
13764       ENDIF
13765       IF(MSOFT.NE.MSMAX) THEN
13766         MSDIFF = MSMAX-MSOFT
13767         MSPAR1 = MSPAR1-MSDIFF
13768         MSPAR2 = MSPAR2-MSDIFF
13769       ENDIF
13770
13771 C  correct for different MSPAR numbers
13772       IF(MSOFT.NE.MSPAR1) THEN
13773         IF(MSPAR1.GT.1) THEN
13774           XDEL = 0.D0
13775           DO 500 I=MSPAR1+1,MSOFT
13776             XDEL = XDEL+XS1(I)
13777  500      CONTINUE
13778           XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13779           DO 550 I=2,MSPAR1
13780             XS1(I) = XS1(I)*XFAC
13781  550      CONTINUE
13782           XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13783         ELSE
13784           XSS1 = XSUM1
13785         ENDIF
13786       ENDIF
13787       IF(MSOFT.NE.MSPAR2) THEN
13788         IF(MSPAR2.GT.1) THEN
13789           XDEL = 0.D0
13790           DO 600 I=MSPAR2+1,MSOFT
13791             XDEL = XDEL+XS2(I)
13792  600      CONTINUE
13793           XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13794           DO 650 I=2,MSPAR2
13795             XS2(I) = XS2(I)*XFAC
13796  650      CONTINUE
13797           XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13798         ELSE
13799           XSS2 = XSUM2
13800         ENDIF
13801       ENDIF
13802
13803 C  first x entry
13804       XS1(1) = 1.D0 - XSS1
13805       XS2(1) = 1.D0 - XSS2
13806       XSUM1 = XSS1
13807       XSUM2 = XSS2
13808
13809 C  debug output
13810       IF(IDEB(60).GE.10) THEN
13811         WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13812      &    'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13813      &    KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13814         WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I  XS1/2   XPOT1/2  XMIN1/2'
13815         DO 30 I=1,MSOFT
13816           WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13817      &      XMIN(1,I),XMIN(2,I)
13818  30     CONTINUE
13819       ENDIF
13820
13821       RETURN
13822
13823 C  not enough phase space
13824  1000 CONTINUE
13825
13826       IFAIL(42) = IFAIL(42)+1
13827       IREJ = 1
13828
13829 C  warning message
13830       IF(IDEB(60).GE.1) THEN
13831         WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13832      &    'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13833      &    ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13834      &    XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13835         WRITE(LO,'(1X,A,1P,3E11.3)')
13836      &    'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13837         WRITE(LO,'(1X,A,1P,3E11.3)')
13838      &    'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13839         WRITE(LO,'(1X,A,1P,3E11.3)')
13840      &    'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13841         WRITE(LO,'(1X,A)')
13842      &    'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13843         DO 27 I=1,MSOFT
13844           WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13845  27     CONTINUE
13846         WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13847      &    'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13848      &    KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13849         WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I   XPOT1/2   XMIN1/2'
13850         DO 25 I=1,MSOFT
13851           WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13852      &    XMIN(1,I),XMIN(2,I)
13853  25     CONTINUE
13854       ENDIF
13855
13856       END
13857
13858 *$ CREATE PHO_SELSXR.FOR
13859 *COPY PHO_SELSXR
13860 CDECK  ID>, PHO_SELSXR
13861       SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13862      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13863 C***********************************************************************
13864 C
13865 C    select x values of soft string ends (rejection method)
13866 C
13867 C***********************************************************************
13868       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13869       SAVE
13870
13871       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13872
13873 C  input/output channels
13874       INTEGER LI,LO
13875       COMMON /POINOU/ LI,LO
13876 C  event debugging information
13877       INTEGER NMAXD
13878       PARAMETER (NMAXD=100)
13879       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13880      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13881       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13882      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13883 C  model switches and parameters
13884       CHARACTER*8 MDLNA
13885       INTEGER ISWMDL,IPAMDL
13886       DOUBLE PRECISION PARMDL
13887       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13888 C  data on most recent hard scattering
13889       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13890       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13891      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13892      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13893       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13894      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13895      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13896      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13897      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13898 C  global event kinematics and particle IDs
13899       INTEGER IFPAP,IFPAB
13900       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13901       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13902 C  obsolete cut-off information
13903       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13904       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13905
13906       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13907
13908       IF(IDEB(13).GE.10) THEN
13909         WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13910         WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13911      &    MSOFT,XS1,XS2,XMAX1,XMAX2
13912         DO 40 I=1,MSOFT
13913           WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13914  40     CONTINUE
13915       ENDIF
13916 C
13917       IREJ = 0
13918 C
13919       XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
13920       XMIN1 = MAX(AS/XMAX1,XMINK)
13921       XMIN2 = MAX(AS/XMAX2,XMINK)
13922 C
13923       IF(MSOFT.EQ.1) THEN
13924         XSOFT1(2) = 0.D0
13925         XSOFT2(2) = 0.D0
13926         RETURN
13927       ENDIF
13928       XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
13929      &        *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
13930 C
13931  10   CONTINUE
13932 C
13933       DO 50 I=2,MSOFT
13934         POT(1,I) = XPOT1(I)+1.D0
13935         POT(2,I) = XPOT2(I)+1.D0
13936         REVP(1,I) = 1.D0/POT(1,I)
13937         REVP(2,I) = 1.D0/POT(2,I)
13938         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
13939         XLMAX = XMAX1**POT(1,I)
13940         XLDIF(1,I) = XLMAX-XLMIN(1,I)
13941         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
13942         XLMAX = XMAX2**POT(2,I)
13943         XLDIF(2,I) = XLMAX-XLMIN(2,I)
13944  50   CONTINUE
13945 C
13946       ITRY0 = 0
13947  5    CONTINUE
13948       ITRY0 = ITRY0 + 1
13949       IF(ITRY0.GE.IPAMDL(181)) THEN
13950         IF(MSOFT-MSMIN.GE.2) THEN
13951           MSOFT = MSMIN
13952           GOTO 10
13953         ENDIF
13954         GOTO 1000
13955       ENDIF
13956       XREST1 = 1.D0-XS1
13957       XREST2 = 1.D0-XS2
13958       DO 100 I=2,MSOFT
13959         ITRY1 = 0
13960
13961  20     CONTINUE
13962         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
13963         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
13964         XSOFT1(I) = Z1**REVP(1,I)
13965         XSOFT2(I) = Z2**REVP(2,I)
13966         ITRY1 = ITRY1+1
13967         IF(ITRY1.GE.50) GOTO 1000
13968         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
13969
13970         XREST1 = XREST1-XSOFT1(I)
13971         IF(XREST1.LT.XMIN1) GOTO 5
13972         IF(XREST1.LT.XMIN(1,1)) GOTO 5
13973         XREST2 = XREST2-XSOFT2(I)
13974         IF(XREST2.LT.XMIN2) GOTO 5
13975         IF(XREST2.LT.XMIN(2,1)) GOTO 5
13976         IF(XREST1*XREST2.LT.AS) GOTO 5
13977
13978  100  CONTINUE
13979       XSOFT1(1) = XREST1
13980       XSOFT2(1) = XREST2
13981       IREJ=0
13982 *     XX = 1.D0
13983 *     DO 200 I=2,MSOFT
13984 *       XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
13985 *200  CONTINUE
13986       XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
13987       IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
13988
13989       XS1 = 1.D0-XREST1
13990       XS2 = 1.D0-XREST2
13991       RETURN
13992
13993  1000 CONTINUE
13994       IREJ = 1
13995       IF(IDEB(13).GE.2) THEN
13996         WRITE(LO,'(1X,A,2I4)')
13997      &    'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
13998         WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
13999       ENDIF
14000
14001       END
14002
14003 *$ CREATE PHO_SELSX2.FOR
14004 *COPY PHO_SELSX2
14005 CDECK  ID>, PHO_SELSX2
14006       SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14007      &                  XS1,XS2,IREJ)
14008 C***********************************************************************
14009 C
14010 C    select x values of soft string ends using PHO_RNDBET
14011 C
14012 C***********************************************************************
14013       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14014       SAVE
14015
14016       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
14017
14018 C  input/output channels
14019       INTEGER LI,LO
14020       COMMON /POINOU/ LI,LO
14021 C  event debugging information
14022       INTEGER NMAXD
14023       PARAMETER (NMAXD=100)
14024       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14025      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14026       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14027      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14028 C  model switches and parameters
14029       CHARACTER*8 MDLNA
14030       INTEGER ISWMDL,IPAMDL
14031       DOUBLE PRECISION PARMDL
14032       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14033 C  data on most recent hard scattering
14034       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14035       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14036      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14037      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14038       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14039      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14040      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14041      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14042      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14043 C  obsolete cut-off information
14044       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14045       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14046
14047       IREJ = 0
14048
14049       IF(IDEB(32).GE.10) THEN
14050         WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14051         WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14052      &    AS,XSUM1,XSUM2,XMAX1,XMAX2
14053         DO 30 I=1,2
14054           WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14055  30     CONTINUE
14056       ENDIF
14057
14058       FAC1 = 1.D0-XSUM1
14059       FAC2 = 1.D0-XSUM2
14060       FAC = FAC1*FAC2
14061       GAM1 = XPOT1(1)+1.D0
14062       GAM2 = XPOT2(1)+1.D0
14063       BET1 = XPOT1(2)+1.D0
14064       BET2 = XPOT2(2)+1.D0
14065
14066       ITRY0 = 0
14067       DO 100 I=1,IPAMDL(182)
14068
14069         ITRY1 = 0
14070  10     CONTINUE
14071           X1 = PHO_RNDBET(GAM1,BET1)
14072           ITRY1 = ITRY1+1
14073           IF(ITRY1.GE.50) GOTO 1000
14074         IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14075
14076         ITRY2 = 0
14077  11     CONTINUE
14078           X2 = PHO_RNDBET(GAM2,BET2)
14079           ITRY2 = ITRY2+1
14080           IF(ITRY2.GE.50) GOTO 1000
14081         IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14082
14083         X3 = 1.D0 - X1
14084         X4 = 1.D0 - X2
14085         IF(X1*X2*FAC.GT.AS) THEN
14086           IF(X3*X4*FAC.GT.AS) THEN
14087             XS1(1) = X1*FAC1
14088             XS1(2) = X3*FAC1
14089             XS2(1) = X2*FAC2
14090             XS2(2) = X4*FAC2
14091             IF(XS1(1).GT.XMIN(1,1)) THEN
14092               IF(XS2(1).GT.XMIN(2,1)) THEN
14093                 IF(XS1(2).GT.XMIN(1,2)) THEN
14094                   IF(XS2(2).GT.XMIN(2,2)) THEN
14095                     XSUM1 = XSUM1+XS1(2)
14096                     XSUM2 = XSUM2+XS2(2)
14097                     GOTO 300
14098                   ENDIF
14099                 ENDIF
14100               ENDIF
14101             ENDIF
14102           ENDIF
14103         ENDIF
14104         ITRY0 = ITRY0+1
14105
14106  100  CONTINUE
14107
14108  1000 CONTINUE
14109       IREJ = 1
14110       IF(IDEB(32).GE.2) THEN
14111         WRITE(LO,'(1X,A,3I4)')
14112      &    'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14113         WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14114       ENDIF
14115       RETURN
14116  300  CONTINUE
14117
14118       END
14119
14120 *$ CREATE PHO_SELSXS.FOR
14121 *COPY PHO_SELSXS
14122 CDECK  ID>, PHO_SELSXS
14123       SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14124      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14125 C***********************************************************************
14126 C
14127 C    select x values of soft string ends (rescaling method)
14128 C
14129 C***********************************************************************
14130       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14131       SAVE
14132
14133       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14134
14135 C  input/output channels
14136       INTEGER LI,LO
14137       COMMON /POINOU/ LI,LO
14138 C  event debugging information
14139       INTEGER NMAXD
14140       PARAMETER (NMAXD=100)
14141       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14142      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14143       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14144      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14145 C  model switches and parameters
14146       CHARACTER*8 MDLNA
14147       INTEGER ISWMDL,IPAMDL
14148       DOUBLE PRECISION PARMDL
14149       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14150 C  data on most recent hard scattering
14151       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14152       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14153      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14154      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14155       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14156      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14157      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14158      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14159      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14160 C  obsolete cut-off information
14161       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14162       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14163
14164       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14165
14166       IREJ = 0
14167
14168  10   CONTINUE
14169
14170       IF(MSOFT.EQ.1) THEN
14171         XSOFT1(1) = 1.D0-XS1
14172         XSOFT1(2) = 0.D0
14173         XSOFT2(1) = 1.D0-XS2
14174         XSOFT2(2) = 0.D0
14175         RETURN
14176       ENDIF
14177
14178       DO 50 I=1,MSOFT
14179         POT(1,I) = XPOT1(I)+1.D0
14180         POT(2,I) = XPOT2(I)+1.D0
14181         REVP(1,I) = 1.D0/POT(1,I)
14182         REVP(2,I) = 1.D0/POT(2,I)
14183         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14184         XLMAX = XMAX1**POT(1,I)
14185         XLDIF(1,I) = XLMAX-XLMIN(1,I)
14186         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14187         XLMAX = XMAX2**POT(2,I)
14188         XLDIF(2,I) = XLMAX-XLMIN(2,I)
14189  50   CONTINUE
14190
14191       ITRY0 = 0
14192  5    CONTINUE
14193       ITRY0 = ITRY0 + 1
14194       IF(ITRY0.GE.IPAMDL(180)) THEN
14195         IF(MSOFT-MSMIN.GE.2) THEN
14196           MSOFT= MSMIN
14197           GOTO 10
14198         ENDIF
14199         GOTO 1000
14200       ENDIF
14201       XSUM1 = 0.D0
14202       XSUM2 = 0.D0
14203       DO 100 I=1,MSOFT
14204         ITRY1 = 0
14205  20     CONTINUE
14206         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14207         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14208         XSOFT1(I) = Z1**REVP(1,I)
14209         XSOFT2(I) = Z2**REVP(2,I)
14210         ITRY1 = ITRY1+1
14211         IF(ITRY1.GE.50) GOTO 1000
14212         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14213         XSUM1 = XSUM1+XSOFT1(I)
14214         XSUM2 = XSUM2+XSOFT2(I)
14215  100  CONTINUE
14216       FAC1 = (1.D0-XS1)/XSUM1
14217       FAC2 = (1.D0-XS2)/XSUM2
14218       DO 200 I=1,MSOFT
14219         XSOFT1(I) = XSOFT1(I)*FAC1
14220         XSOFT2(I) = XSOFT2(I)*FAC2
14221         IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14222         IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14223         IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14224  200  CONTINUE
14225
14226       XS1 = 1.D0-XSOFT1(1)
14227       XS2 = 1.D0-XSOFT2(1)
14228       RETURN
14229
14230  1000 CONTINUE
14231       IREJ = 1
14232       IF(IDEB(14).GE.2) THEN
14233         WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14234      &    'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14235         DO 300 I=1,MSOFT
14236           WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14237  300    CONTINUE
14238       ENDIF
14239
14240       END
14241
14242 *$ CREATE PHO_SELSXI.FOR
14243 *COPY PHO_SELSXI
14244 CDECK  ID>, PHO_SELSXI
14245       SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14246      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14247 C***********************************************************************
14248 C
14249 C    select x values of soft string ends (sea independent from valence)
14250 C
14251 C***********************************************************************
14252       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14253       SAVE
14254
14255       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14256
14257 C  input/output channels
14258       INTEGER LI,LO
14259       COMMON /POINOU/ LI,LO
14260 C  event debugging information
14261       INTEGER NMAXD
14262       PARAMETER (NMAXD=100)
14263       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14264      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14265       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14266      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14267 C  model switches and parameters
14268       CHARACTER*8 MDLNA
14269       INTEGER ISWMDL,IPAMDL
14270       DOUBLE PRECISION PARMDL
14271       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14272 C  data on most recent hard scattering
14273       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14274       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14275      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14276      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14277       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14278      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14279      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14280      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14281      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14282 C  obsolete cut-off information
14283       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14284       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14285
14286       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14287
14288       IREJ = 0
14289
14290  10   CONTINUE
14291
14292       DO 50 I=1,MSOFT
14293         POT(1,I) = XPOT1(I)+1.D0
14294         POT(2,I) = XPOT2(I)+1.D0
14295         REVP(1,I) = 1.D0/POT(1,I)
14296         REVP(2,I) = 1.D0/POT(2,I)
14297         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14298         XLMAX = XMAX1**POT(1,I)
14299         XLDIF(1,I) = XLMAX-XLMIN(1,I)
14300         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14301         XLMAX = XMAX2**POT(2,I)
14302         XLDIF(2,I) = XLMAX-XLMIN(2,I)
14303  50   CONTINUE
14304
14305 C  selection of sea
14306       ITRY0 = 0
14307  5    CONTINUE
14308
14309       ITRY0 = ITRY0 + 1
14310       IF(ITRY0.GE.IPAMDL(183)) THEN
14311         IF(MSOFT-MSMIN.GE.2) THEN
14312           MSOFT = MSMIN
14313           GOTO 10
14314         ENDIF
14315         GOTO 1000
14316       ENDIF
14317       XSUM1 = XS1
14318       XSUM2 = XS2
14319       DO 100 I=3,MSOFT
14320         ITRY1 = 0
14321  20     CONTINUE
14322         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14323         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14324         XSOFT1(I) = Z1**REVP(1,I)
14325         XSOFT2(I) = Z2**REVP(2,I)
14326         ITRY1 = ITRY1+1
14327         IF(ITRY1.GE.50) GOTO 1000
14328         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14329         XSUM1 = XSUM1+XSOFT1(I)
14330         XSUM2 = XSUM2+XSOFT2(I)
14331  100  CONTINUE
14332
14333       IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14334       IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14335
14336 C  selection of valence
14337       CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14338      &  XSOFT1,XSOFT2,IREJ)
14339       IF(IREJ.NE.0) THEN
14340         IF(MSOFT-MSMIN.GE.2) THEN
14341           MSOFT = MSMIN
14342           GOTO 10
14343         ENDIF
14344         IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14345      &    'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14346      &    XSUM1,XSUM2,XMAX1,XMAX2
14347         RETURN
14348       ENDIF
14349
14350       XS1 = 1.D0-XSOFT1(1)
14351       XS2 = 1.D0-XSOFT2(1)
14352       RETURN
14353
14354  1000 CONTINUE
14355       IREJ = 1
14356       IF(IDEB(14).GE.2) THEN
14357         WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14358      &    'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14359         DO 300 I=1,MSOFT
14360           WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14361  300    CONTINUE
14362       ENDIF
14363
14364       END
14365
14366 *$ CREATE PHO_SELCOL.FOR
14367 *COPY PHO_SELCOL
14368 CDECK  ID>, PHO_SELCOL
14369       SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14370 C********************************************************************
14371 C
14372 C    color combinatorics
14373 C
14374 C    input:         ICO1,2   colors of incoming particle
14375 C                   IMODE    -2  output of initialization status
14376 C                            -1  initialization
14377 C                                   ICINP(1) selection mode
14378 C                                            0   QCD
14379 C                                            1   large N_c expansion
14380 C                                   ICINP(2) max. allowed color
14381 C                            0   clear internal color counter
14382 C                            1   hadron into two colored objects
14383 C                            2   quark into quark gluon
14384 C                            3   gluon into gluon gluon
14385 C                            4   gluon into quark antiquark
14386 C
14387 C    output:        ICOA1,2  colors of first outgoing particle
14388 C                   ICOB1,2  colors of second outgoing particle
14389 C
14390 C********************************************************************
14391       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14392       SAVE
14393
14394 C  input/output channels
14395       INTEGER LI,LO
14396       COMMON /POINOU/ LI,LO
14397 C  event debugging information
14398       INTEGER NMAXD
14399       PARAMETER (NMAXD=100)
14400       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14401      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14402       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14403      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14404
14405       DATA METHOD /0/, II /0/
14406
14407       ICI1 = ICO1
14408       ICI2 = ICO2
14409       IF(METHOD.EQ.0) THEN
14410
14411         IF(IMODE.EQ.1) THEN
14412           II = II+1
14413           IF(II.GT.MAXCOL)
14414      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14415           ICOA1 = II
14416           ICOA2 = 0
14417           ICOB1 = -II
14418           ICOB2 = 0
14419         ELSE IF(IMODE.EQ.2) THEN
14420           II = II+1
14421           IF(II.GT.MAXCOL)
14422      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14423           ICOA2 = 0
14424           IF(ICI1.GT.0) THEN
14425             ICOA1 = II
14426             ICOB1 = ICI1
14427             ICOB2 = -II
14428           ELSE
14429             ICOA1 = -II
14430             ICOB1 = II
14431             ICOB2 = ICI1
14432           ENDIF
14433         ELSE IF(IMODE.EQ.3) THEN
14434           II = II+1
14435           IF(II.GT.MAXCOL)
14436      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14437           IF(DT_RNDM(DUM).GT.0.5D0) THEN
14438             ICOA1 = ICI1
14439             ICOA2 = -II
14440             ICOB1 = II
14441             ICOB2 = ICI2
14442           ELSE
14443             ICOB1 = ICI1
14444             ICOB2 = -II
14445             ICOA1 = II
14446             ICOA2 = ICI2
14447           ENDIF
14448         ELSE IF(IMODE.EQ.4) THEN
14449           ICOA1 = ICI1
14450           ICOA2 = 0
14451           ICOB1 = ICI2
14452           ICOB2 = 0
14453         ELSE IF(IMODE.EQ.0) THEN
14454           II = 0
14455         ELSE IF(IMODE.EQ.-1) THEN
14456           METHOD = ICI1
14457           MAXCOL = ICI2
14458         ELSE IF(IMODE.EQ.-2) THEN
14459           WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14460      &      METHOD,MAXCOL
14461         ELSE
14462           WRITE(LO,'(1X,A,I5)')
14463      &      'PHO_SELCOL:ERROR: unsupported mode',IMODE
14464           CALL PHO_ABORT
14465         ENDIF
14466
14467       ELSE
14468         WRITE(LO,'(1X,A,I5)')
14469      &    'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14470         CALL PHO_ABORT
14471       ENDIF
14472
14473       II = ABS(II)
14474       IF(IDEB(75).GE.10) THEN
14475         WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14476      &    IMODE,MAXCOL,II
14477         WRITE(LO,'(10X,A,2I5)') 'input  colors',ICI1,ICI2
14478         WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14479       ENDIF
14480
14481       END
14482
14483 *$ CREATE ipho_diqu.FOR
14484 *COPY ipho_diqu
14485 CDECK  ID>, ipho_diqu
14486       INTEGER FUNCTION ipho_diqu(iq1,iq2)
14487 C***********************************************************************
14488 C
14489 C     selection of diquark number (PDG convention)
14490 C
14491 C***********************************************************************
14492       IMPLICIT NONE
14493       SAVE
14494
14495       integer iq1,iq2
14496
14497 C  input/output channels
14498       INTEGER LI,LO
14499       COMMON /POINOU/ LI,LO
14500 C  event debugging information
14501       INTEGER NMAXD
14502       PARAMETER (NMAXD=100)
14503       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14504      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14505       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14506      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14507 C  model switches and parameters
14508       CHARACTER*8 MDLNA
14509       INTEGER ISWMDL,IPAMDL
14510       DOUBLE PRECISION PARMDL
14511       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14512
14513 C  external functions
14514       double precision DT_RNDM
14515
14516 C  local variables
14517       integer i0,i1,i2
14518       double precision dum
14519
14520       i1 = abs(iq1)
14521       i2 = abs(iq2)
14522
14523       if(i1.eq.i2) then
14524         i0 = i1*1100+3
14525       else
14526         i0 = max(i1,i2)*1000+min(i1,i2)*100
14527         if(DT_RNDM(dum).gt.PARMDL(135)) then
14528           i0 = i0+1
14529         else
14530           i0 = i0+3
14531         endif
14532       endif
14533
14534       ipho_diqu = sign(i0,iq1)
14535
14536       END
14537
14538 *$ CREATE PHO_PARREM.FOR
14539 *COPY PHO_PARREM
14540 CDECK  ID>, PHO_PARREM
14541       SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14542 C**********************************************************************
14543 C
14544 C     selection of particle remnant flavour(s) (quark or diquark)
14545 C
14546 C     input:    INDX   index of particle in /POEVT1/
14547 C               IOUT   parton which was taken out
14548 C
14549 C     output:   IREM   remnant according to valence flavours
14550 C               IREJ   0  flavour combination possible
14551 C                      1  flavour combination impossible
14552 C
14553 C     all particle ID are given according to PDG conventions
14554 C
14555 C**********************************************************************
14556       IMPLICIT NONE
14557       SAVE
14558
14559       integer INDX,IOUT,IREM,IREJ
14560
14561 C  input/output channels
14562       INTEGER LI,LO
14563       COMMON /POINOU/ LI,LO
14564 C  event debugging information
14565       INTEGER NMAXD
14566       PARAMETER (NMAXD=100)
14567       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14568      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14569       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14570      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14571 C  standard particle data interface
14572       INTEGER NMXHEP
14573       PARAMETER (NMXHEP=4000)
14574       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14575       DOUBLE PRECISION PHEP,VHEP
14576       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14577      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14578      &                VHEP(4,NMXHEP)
14579 C  extension to standard particle data interface (PHOJET specific)
14580       INTEGER IMPART,IPHIST,ICOLOR
14581       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14582 C  general particle data
14583       double precision xm_list,tau_list,gam_list,
14584      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14585      &  xm_bb82_list,xm_bb102_list
14586       integer          ich3_list,iba3_list,iq_list,
14587      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
14588       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14589      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
14590      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14591      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14592      &  ich3_list(300),iba3_list(300),iq_list(3,300),
14593      &  id_psm_list(6,6),id_vem_list(6,6),
14594      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
14595
14596 C  external functions
14597       integer ipho_diqu
14598
14599 C  local variables
14600       integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14601       dimension IQUA(3),IDQ(2)
14602
14603       ID1 = IDHEP(INDX)
14604       ID2 = IMPART(INDX)
14605       IREJ = 0
14606
14607       IF(ID2.EQ.0) THEN
14608         WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14609         CALL PHO_ABORT
14610       ENDIF
14611
14612 C  particle with flavour mixing
14613       if(ID1.eq.22) then
14614 C  photon
14615         IREM = -IOUT
14616         GOTO 100
14617       else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14618 C  pi0, rho0, and omega
14619         IF(ABS(IOUT).LE.2) THEN
14620           IREM = -IOUT
14621           GOTO 100
14622         ELSE
14623           GOTO 150
14624         ENDIF
14625       else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14626 C  neutral kaons (K0,K0-bar)
14627         if(abs(IOUT).eq.1) then
14628           IREM = sign(3,-IOUT)
14629           goto 100
14630         else if(abs(IOUT).eq.3) then
14631           IREM = sign(1,-IOUT)
14632           goto 100
14633         else
14634           goto 150
14635         endif
14636       else if((ID1.eq.990).or.(ID1.eq.110)) then
14637 C  pomeron and reggeon
14638         IREM = -IOUT
14639         GOTO 100
14640       endif
14641
14642 C  ordinary hadron
14643       ID = abs(ID2)
14644       IS = sign(1,ID2)
14645       IQUA(1) = iq_list(1,ID)*IS
14646       IQUA(2) = iq_list(2,ID)*IS
14647       IQUA(3) = iq_list(3,ID)*IS
14648
14649 C  compare to flavour content
14650       IF(ABS(IOUT).LT.1000) THEN
14651 C  single quark requested
14652         IF(IQUA(1).EQ.IOUT) THEN
14653           K1 = 2
14654           K2 = 3
14655         ELSE IF(IQUA(2).EQ.IOUT) THEN
14656           K1 = 1
14657           K2 = 3
14658         ELSE IF(IQUA(3).EQ.IOUT) THEN
14659           K1 = 1
14660           K2 = 2
14661         ELSE
14662           GOTO 150
14663         ENDIF
14664         IF(IQUA(3).EQ.0) THEN
14665           IREM = IQUA(K1)
14666         ELSE
14667           IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14668         ENDIF
14669       ELSE IF(IQUA(3).NE.0) THEN
14670 C  diquark requested from baryon
14671         IDQ(1) = IOUT/1000
14672         IDQ(2) = (IOUT-IDQ(1)*1000)/100
14673         do i=1,2
14674           do k=1,3
14675             if(IDQ(i).eq.IQUA(k)) then
14676               IQUA(k) = 0
14677               goto 110
14678             endif
14679           enddo
14680           goto 150
14681  110      continue
14682         enddo
14683         IREM = IQUA(1)+IQUA(2)+IQUA(3)
14684       ENDIF
14685
14686  100  CONTINUE
14687 C  debug output
14688       IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14689      &  'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14690      &  INDX,ID1,ID2,IOUT,IREM
14691       RETURN
14692
14693 C  rejection
14694  150  CONTINUE
14695       IREJ = 1
14696       IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14697      &  'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14698
14699       END
14700
14701 *$ CREATE PHO_VALFLA.FOR
14702 *COPY PHO_VALFLA
14703 CDECK  ID>, PHO_VALFLA
14704       SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14705 C***********************************************************************
14706 C
14707 C     selection of valence flavour decomposition of particle IPAR
14708 C
14709 C     input:    IPAR   particle index in /POEVT1/
14710 C                      -1   initialization
14711 C                      -2   output of statistics
14712 C               XMASS  mass of particle
14713 C                      (important for pomeron:
14714 C                       mass dependent flavour sampling)
14715 C
14716 C     output:   IFL1,IFL2
14717 C               baryon: IFL1  diquark flavour
14718 C               (valence flavours according to PDG conventions)
14719 C
14720 C***********************************************************************
14721       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14722       SAVE
14723
14724       PARAMETER ( EPS    =  0.1D0,
14725      &            DEPS   =  1.D-15)
14726
14727 C  input/output channels
14728       INTEGER LI,LO
14729       COMMON /POINOU/ LI,LO
14730 C  event debugging information
14731       INTEGER NMAXD
14732       PARAMETER (NMAXD=100)
14733       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14734      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14735       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14736      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14737 C  model switches and parameters
14738       CHARACTER*8 MDLNA
14739       INTEGER ISWMDL,IPAMDL
14740       DOUBLE PRECISION PARMDL
14741       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14742 C  standard particle data interface
14743       INTEGER NMXHEP
14744       PARAMETER (NMXHEP=4000)
14745       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14746       DOUBLE PRECISION PHEP,VHEP
14747       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14748      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14749      &                VHEP(4,NMXHEP)
14750 C  extension to standard particle data interface (PHOJET specific)
14751       INTEGER IMPART,IPHIST,ICOLOR
14752       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14753 C  general particle data
14754       double precision xm_list,tau_list,gam_list,
14755      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14756      &  xm_bb82_list,xm_bb102_list
14757       integer          ich3_list,iba3_list,iq_list,
14758      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
14759       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14760      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
14761      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14762      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14763      &  ich3_list(300),iba3_list(300),iq_list(3,300),
14764      &  id_psm_list(6,6),id_vem_list(6,6),
14765      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
14766
14767       data ITMX / 5 /
14768
14769       IF(IPAR.GT.0) THEN
14770         K = IPAR
14771 C  select particle code
14772         ID1 = IDHEP(K)
14773         ID  = abs(IMPART(K))
14774         IBAR = IPHO_BAR3(K,2)
14775         ITER = 0
14776
14777  10     CONTINUE
14778
14779         ifl1 = 0
14780         ifl2 = 0
14781         ITER = ITER+1
14782         if(ITER.GT.ITMX) then
14783           WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14784      &      'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14785           return
14786         endif
14787
14788 C  not baryon
14789         IF(IBAR.EQ.0) THEN
14790
14791 C  photon
14792           IF(ID1.EQ.22) THEN
14793 C  charge dependent flavour sampling
14794  15         CONTINUE
14795             K = INT(DT_RNDM(E1)*6.D0)+1
14796             IF(K.LE.4) THEN
14797               IFL1 = 2
14798               IFL2 = -2
14799             ELSE IF(K.EQ.5) THEN
14800               IFL1 = 1
14801               IFL2 = -1
14802             ELSE
14803               IFL1 = 3
14804               IFL2 = -3
14805             ENDIF
14806 C  optional strangeness suppression
14807             IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14808             IF(DT_RNDM(DUM).LT.0.5D0) THEN
14809               K = IFL1
14810               IFL1 = IFL2
14811               IFL2 = K
14812             ENDIF
14813
14814 C  pomeron, reggeon
14815           ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14816             IF(ISWMDL(19).EQ.0) THEN
14817 C  SU(3) symmetric valences
14818               K = INT(DT_RNDM(E1)*3.D0)+1
14819               IF(DT_RNDM(DUM).LT.0.5D0) THEN
14820                 IFL1 = K
14821               ELSE
14822                 IFL1 = -K
14823               ENDIF
14824               IFL2 = -IFL1
14825             ELSE IF(ISWMDL(19).EQ.1) THEN
14826 C  mass dependent flavour sampling
14827               EMIN = MIN(E1,E2)
14828               CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14829             ELSE
14830               WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14831      &          'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14832               CALL PHO_ABORT
14833             ENDIF
14834
14835 C  meson with flavour mixing
14836           ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14837             K = INT(2.D0*DT_RNDM(E1))+1
14838             IFL1 = K
14839             IFL2 = -K
14840 C  meson (standard)
14841           ELSE
14842             K = INT(2.D0*DT_RNDM(E1))+1
14843             IFL1 = iq_list(K,ID)
14844             K = MOD(K,2) + 1
14845             IFL2 = iq_list(K,ID)
14846             if(IFL1.EQ.0) then
14847               EMIN = MIN(E1,E2)
14848               CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14849             endif
14850           ENDIF
14851
14852 C  baryon
14853         ELSE
14854           K = INT(2.999999D0*DT_RNDM(E2))+1
14855           K1 = MOD(K,3)+1
14856           K2 = MOD(K1,3)+1
14857           IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14858           IFL2 = iq_list(K,ID)
14859         ENDIF
14860
14861 C  change sign for antiparticles
14862         if(ID1.lt.0) then
14863           IFL1 = -IFL1
14864           IFL2 = -IFL2
14865         endif
14866
14867 ************************************************************************
14868 C  check kinematic constraints
14869 *       IF((PHO_PMASS(IFL1,3).GT.E1)
14870 *    &     .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14871 ************************************************************************
14872
14873 C  debug output
14874         IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14875      &    'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14876
14877       ELSE IF(IPAR.EQ.-1) THEN
14878 C  initialization
14879
14880       ELSE IF(IPAR.EQ.-2) THEN
14881 C  output of final statistics
14882
14883       ELSE
14884         WRITE(LO,'(1X,A,I10)')
14885      &    'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14886         CALL PHO_ABORT
14887       ENDIF
14888
14889       END
14890
14891 *$ CREATE PHO_REGFLA.FOR
14892 *COPY PHO_REGFLA
14893 CDECK  ID>, PHO_REGFLA
14894       SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14895 C**********************************************************************
14896 C
14897 C     selection of reggeon flavours
14898 C
14899 C     input:    JM1,JM2      position index of mother hadrons
14900 C
14901 C     output:   IFLR1,IFLR2  valence flavours according to
14902 C                            PDG conventions and JM1,JM2
14903 C               IREJ         0  reggeon possible
14904 C                            1  reggeon impossible
14905 C
14906 C**********************************************************************
14907       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14908       SAVE
14909
14910       PARAMETER ( EPS    =  0.1D0,
14911      &            DEPS   =  1.D-15)
14912
14913 C  input/output channels
14914       INTEGER LI,LO
14915       COMMON /POINOU/ LI,LO
14916 C  event debugging information
14917       INTEGER NMAXD
14918       PARAMETER (NMAXD=100)
14919       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14920      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14921       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14922      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14923 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
14924       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
14925       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
14926       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
14927      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
14928 C  standard particle data interface
14929       INTEGER NMXHEP
14930       PARAMETER (NMXHEP=4000)
14931       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14932       DOUBLE PRECISION PHEP,VHEP
14933       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14934      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14935      &                VHEP(4,NMXHEP)
14936 C  extension to standard particle data interface (PHOJET specific)
14937       INTEGER IMPART,IPHIST,ICOLOR
14938       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14939
14940       IF(JM1.GT.0) THEN
14941         IREJ = 0
14942         ITER = 0
14943 C  available energy
14944         E1   = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
14945      &             -(PHEP(1,JM1)+PHEP(1,JM2))**2
14946      &             -(PHEP(2,JM1)+PHEP(2,JM2))**2
14947      &             -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
14948  50     CONTINUE
14949         ITER = ITER+1
14950         IF(ITER.GT.50) THEN
14951           IREJ = 1
14952 C  debug output
14953           IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
14954      &      'PHO_REGFLA: rejection, no reggeon found for',
14955      &      IDHEP(JM1),IDHEP(JM2),E1
14956           RETURN
14957         ENDIF
14958
14959         CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
14960         CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
14961         IF(IFLA1.EQ.-IFLB1) THEN
14962           IFLR1 = IFLA2
14963           IFLR2 = IFLB2
14964         ELSE IF(IFLA1.EQ.-IFLB2) THEN
14965           IFLR1 = IFLA2
14966           IFLR2 = IFLB1
14967         ELSE IF(IFLA2.EQ.-IFLB1) THEN
14968           IFLR1 = IFLA1
14969           IFLR2 = IFLB2
14970         ELSE IF(IFLA2.EQ.-IFLB2) THEN
14971           IFLR1 = IFLA1
14972           IFLR2 = IFLB1
14973         ELSE
14974 C  debug output
14975           IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
14976      &      'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
14977           GOTO 50
14978         ENDIF
14979 C  debug output
14980         IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
14981      &    'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
14982      &    JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
14983       ELSE IF(JM1.EQ.-1) THEN
14984 C  initialization
14985       ELSE IF(JM1.EQ.-2) THEN
14986 C  output of statistics
14987       ELSE
14988         WRITE(LO,'(1X,A,I10)')
14989      &    'PHO_REGFLA: invalid mother particle (JM1)',JM1
14990         CALL PHO_ABORT
14991       ENDIF
14992
14993       END
14994
14995 *$ CREATE PHO_SEAFLA.FOR
14996 *COPY PHO_SEAFLA
14997 CDECK  ID>, PHO_SEAFLA
14998       SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
14999 C**********************************************************************
15000 C
15001 C     selection of sea flavour content of particle IPAR
15002 C
15003 C     input:    IPAR    particle index in /POEVT1/
15004 C               CHMASS  available invariant string mass
15005 C                       positive mass --> use BAMJET method
15006 C                       negative mass --> SU(3) symmetric sea according
15007 C                       to values given in PARMDL(1-6)
15008 C               IPAR    -1 initialization
15009 C                       -2 output of statistics
15010 C
15011 C     output:   sea flavours according to PDG conventions
15012 C
15013 C**********************************************************************
15014       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15015       SAVE
15016
15017       PARAMETER ( EPS    =  0.1D0,
15018      &            DEPS   =  1.D-15)
15019
15020 C  input/output channels
15021       INTEGER LI,LO
15022       COMMON /POINOU/ LI,LO
15023 C  event debugging information
15024       INTEGER NMAXD
15025       PARAMETER (NMAXD=100)
15026       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15027      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15028       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15029      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15030 C  model switches and parameters
15031       CHARACTER*8 MDLNA
15032       INTEGER ISWMDL,IPAMDL
15033       DOUBLE PRECISION PARMDL
15034       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15035 C  some hadron information, will be deleted in future versions
15036       INTEGER NFS
15037       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15038       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15039
15040       IF(IPAR.GT.0) THEN
15041         IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15042 C  constant weights for sea
15043  15       CONTINUE
15044             SUM = 0.D0
15045             DO 40 K=1,NFSEA
15046               SUM = SUM + PARMDL(K)
15047  40         CONTINUE
15048             XI = DT_RNDM(SUM)*SUM
15049             SUM = 0.D0
15050             DO 50 K=1,NFSEA
15051               SUM = SUM + PARMDL(K)
15052               IF(XI.LE.SUM) GOTO 55
15053  50         CONTINUE
15054  55         CONTINUE
15055           IF(K.GT.NFSEA) GOTO 15
15056         ELSE
15057 C  mass dependent flavour sampling
15058  10       CONTINUE
15059             CALL PHO_FLAUX(CHMASS,K)
15060           IF(K.GT.NFSEA) GOTO 10
15061         ENDIF
15062         IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15063         IFL1 = K
15064         IFL2 = -K
15065         IF(IDEB(46).GE.10) THEN
15066           WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15067      &      IPAR,IFL1,IFL2,CHMASS
15068         ENDIF
15069       ELSE IF(IPAR.EQ.-1) THEN
15070 C  initialization
15071         NFSEA = NFS
15072       ELSE IF(IPAR.EQ.-2) THEN
15073 C  output of statistics
15074       ELSE
15075         WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15076         CALL PHO_ABORT
15077       ENDIF
15078
15079       END
15080
15081 *$ CREATE PHO_FLAUX.FOR
15082 *COPY PHO_FLAUX
15083 CDECK  ID>, PHO_FLAUX
15084       SUBROUTINE PHO_FLAUX(EQUARK,K)
15085 C***********************************************************************
15086 C
15087 C    auxiliary subroutine to select flavours
15088 C
15089 C********************************************************************
15090       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15091       SAVE
15092
15093       PARAMETER ( DEPS   =  1.D-14 )
15094
15095 C  input/output channels
15096       INTEGER LI,LO
15097       COMMON /POINOU/ LI,LO
15098 C  event debugging information
15099       INTEGER NMAXD
15100       PARAMETER (NMAXD=100)
15101       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15102      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15103       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15104      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15105 C  some hadron information, will be deleted in future versions
15106       INTEGER NFS
15107       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15108       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15109
15110       DIMENSION WGHT(9)
15111
15112 C  calculate weights for given energy
15113       IF(EQUARK.LT.QMASS(1)) THEN
15114         IF(IDEB(16).GE.5)
15115      &    WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15116      &      EQUARK
15117         WGHT(1) = 0.5D0
15118         WGHT(2) = 0.5D0
15119         WGHT(3) = 0.D0
15120         WGHT(4) = 0.D0
15121         SUM = 1.D0
15122       ELSE
15123         SUM = 0.D0
15124         DO 305 K=1,NFS
15125           IF(EQUARK.GT.QMASS(K)) THEN
15126             WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15127           ELSE
15128             WGHT(K) = 0.D0
15129           ENDIF
15130           SUM = SUM + WGHT(K)
15131  305    CONTINUE
15132       ENDIF
15133 C  sample flavours
15134       XI = SUM*(DT_RNDM(SUM)-DEPS)
15135       K = 0
15136       SUM = 0.D0
15137  400  CONTINUE
15138         K = K+1
15139         SUM = SUM + WGHT(K)
15140       IF(XI.GT.SUM) GOTO 400
15141 C  debug output
15142       IF(IDEB(16).GE.20) THEN
15143         WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15144       ENDIF
15145       END
15146
15147 *$ CREATE PHO_BETAF.FOR
15148 *COPY PHO_BETAF
15149 CDECK  ID>, PHO_BETAF
15150       DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15151 C********************************************************************
15152 C
15153 C     weights of different quark flavours
15154 C
15155 C********************************************************************
15156       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15157       SAVE
15158
15159       AX=0.D0
15160       BETX1=BET*X1
15161       IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15162       AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15163
15164       PHO_BETAF=AX+AY
15165
15166       END
15167
15168 *$ CREATE PHO_MCHECK.FOR
15169 *COPY PHO_MCHECK
15170 CDECK  ID>, PHO_MCHECK
15171       SUBROUTINE PHO_MCHECK(J1,IREJ)
15172 C********************************************************************
15173 C
15174 C    check parton momenta for fragmentation
15175 C
15176 C    input:      J1      first  string number
15177 C                        /POEVT1/
15178 C                        /POSTRG/
15179 C
15180 C    output:             /POEVT1/
15181 C                        /POSTRG/
15182 C                IREJ    0  successful
15183 C                        1  failure
15184 C
15185 C    in case of very small string mass:
15186 C                NNCH    mass label of string
15187 C                        0  string
15188 C                       -1  octett baryon / pseudo scalar meson
15189 C                        1  decuplett baryon / vector meson
15190 C                IBHAD   hadron number according to CPC,
15191 C                        string will be treated as resonance
15192 C                        (sometimes far off mass shell)
15193 C
15194 C    constant WIDTH ( 0.01GeV ) determines range of acceptance
15195 C
15196 C********************************************************************
15197       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15198       SAVE
15199
15200       PARAMETER ( WIDTH  =  0.01D0,
15201      &            DEPS   =  1.D-15 )
15202
15203 C  input/output channels
15204       INTEGER LI,LO
15205       COMMON /POINOU/ LI,LO
15206 C  event debugging information
15207       INTEGER NMAXD
15208       PARAMETER (NMAXD=100)
15209       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15210      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15211       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15212      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15213 C  model switches and parameters
15214       CHARACTER*8 MDLNA
15215       INTEGER ISWMDL,IPAMDL
15216       DOUBLE PRECISION PARMDL
15217       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15218 C  standard particle data interface
15219       INTEGER NMXHEP
15220       PARAMETER (NMXHEP=4000)
15221       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15222       DOUBLE PRECISION PHEP,VHEP
15223       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15224      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15225      &                VHEP(4,NMXHEP)
15226 C  extension to standard particle data interface (PHOJET specific)
15227       INTEGER IMPART,IPHIST,ICOLOR
15228       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15229 C  color string configurations including collapsed strings and hadrons
15230       INTEGER MSTR
15231       PARAMETER (MSTR=500)
15232       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15233       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15234      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15235      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15236 C  internal rejection counters
15237       INTEGER NMXJ
15238       PARAMETER (NMXJ=60)
15239       CHARACTER*10 REJTIT
15240       INTEGER IFAIL
15241       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15242
15243       IREJ = 0
15244 C  quark antiquark jet
15245       STRM = PHEP(5,NPOS(1,J1))
15246       IF(NCODE(J1).EQ.3) THEN
15247         CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15248      &    AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15249         IF(IDEB(18).GE.5)
15250      &    WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15251      &      'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15252      &      J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15253         IF(STRM.LT.AMPS) THEN
15254           IREJ = 1
15255           IFAIL(20) = IFAIL(20) + 1
15256           RETURN
15257         ELSE IF(STRM.LT.AMPS2) THEN
15258           IF(STRM.LT.(AMVE-WIDTH)) THEN
15259             NNCH(J1) = -1
15260             IBHAD(J1) = IPS
15261           ELSE
15262             NNCH(J1) = 1
15263             IBHAD(J1) = IVE
15264           ENDIF
15265         ELSE
15266           NNCH(J1) = 0
15267           IBHAD(J1) = 0
15268         ENDIF
15269 C  quark diquark or v.s. jet
15270       ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15271         CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15272      &              AM8,AM82,AM10,AM102,I8,I10)
15273         IF(IDEB(18).GE.5)
15274      &    WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15275      &            'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15276      &            J1,STRM,AM8,AM82,AM10,AM102
15277         IF(STRM.LT.AM8) THEN
15278           IREJ = 1
15279           IFAIL(19) = IFAIL(19) + 1
15280           RETURN
15281         ELSE IF(STRM.LT.AM82) THEN
15282           IF(STRM.LT.(AM10-WIDTH)) THEN
15283             NNCH(J1) = -1
15284             IBHAD(J1) = I8
15285           ELSE
15286             NNCH(J1) = 1
15287             IBHAD(J1) = I10
15288           ENDIF
15289         ELSE
15290           NNCH(J1) = 0
15291           IBHAD(J1) = 0
15292         ENDIF
15293 C  diquark a-diquark string
15294       ELSE IF(NCODE(J1).EQ.5) THEN
15295         CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15296      &              AM82,AM102)
15297         IF(IDEB(18).GE.5)
15298      &    WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15299      &            'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15300      &            J1,STRM,AM82,AM102
15301         IF(STRM.LT.AM82) THEN
15302           IREJ = 1
15303           IFAIL(19) = IFAIL(19) + 1
15304           RETURN
15305         ELSE
15306           NNCH(J1) = 0
15307           IBHAD(J1) = 0
15308         ENDIF
15309       ELSE IF(NCODE(J1).LT.0) THEN
15310         RETURN
15311       ELSE
15312         WRITE(LO,'(/,1X,2A,2I8)')  'PHO_MCHECK: ',
15313      &    'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15314         CALL PHO_ABORT
15315       ENDIF
15316       END
15317
15318 *$ CREATE PHO_POMCOR.FOR
15319 *COPY PHO_POMCOR
15320 CDECK  ID>, PHO_POMCOR
15321       SUBROUTINE PHO_POMCOR(IREJ)
15322 C********************************************************************
15323 C
15324 C    join quarks to gluons in case of too small masses
15325 C
15326 C    input:              /POEVT1/
15327 C                        /POSTRG/
15328 C                IREJ    -1          initialization
15329 C                        -2          output of statistics
15330 C
15331 C    output:             /POEVT1/
15332 C                        /POSTRG/
15333 C                IREJ    0  successful
15334 C                        1  failure
15335 C
15336 C
15337 C********************************************************************
15338       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15339       SAVE
15340
15341       PARAMETER ( EPS    =  1.D-10 )
15342
15343 C  input/output channels
15344       INTEGER LI,LO
15345       COMMON /POINOU/ LI,LO
15346 C  event debugging information
15347       INTEGER NMAXD
15348       PARAMETER (NMAXD=100)
15349       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15350      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15351       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15352      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15353 C  model switches and parameters
15354       CHARACTER*8 MDLNA
15355       INTEGER ISWMDL,IPAMDL
15356       DOUBLE PRECISION PARMDL
15357       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15358 C  standard particle data interface
15359       INTEGER NMXHEP
15360       PARAMETER (NMXHEP=4000)
15361       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15362       DOUBLE PRECISION PHEP,VHEP
15363       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15364      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15365      &                VHEP(4,NMXHEP)
15366 C  extension to standard particle data interface (PHOJET specific)
15367       INTEGER IMPART,IPHIST,ICOLOR
15368       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15369 C  color string configurations including collapsed strings and hadrons
15370       INTEGER MSTR
15371       PARAMETER (MSTR=500)
15372       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15373       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15374      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15375      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15376
15377       DIMENSION PJ(4)
15378
15379       IF(IREJ.EQ.-1) THEN
15380         ICTOT = 0
15381         ICCOR = 0
15382         RETURN
15383       ELSE IF(IREJ.EQ.-2) THEN
15384         WRITE(LO,'(/1X,A,2I8)')
15385      &    'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15386         RETURN
15387       ENDIF
15388 C
15389       IREJ = 0
15390 C
15391       NITER = 100
15392       ITER = 0
15393       ICTOT = ICTOT+ISTR
15394       IF(ISWMDL(25).LE.0) RETURN
15395 C  debug string entries
15396       IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15397 C
15398  50   CONTINUE
15399       ITER = ITER+1
15400       IF(ITER.GE.NITER) THEN
15401         IREJ = 1
15402         IF(IDEB(83).GE.2) THEN
15403           WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15404           IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15405         ENDIF
15406         RETURN
15407       ENDIF
15408 C
15409 C  check mass limits
15410       ISTRO = ISTR
15411       DO 100 I=1,ISTRO
15412         IF(NCODE(I).LT.0) GOTO 99
15413         J1 = NPOS(1,I)
15414         NRPOM = IPHIST(2,J1)
15415         IF(NRPOM.GE.100) GOTO 99
15416         CMASS0 = PHEP(5,J1)
15417 C  get masses
15418         IF(NCODE(I).EQ.3) THEN
15419           CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15420         ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15421           CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15422      &                AM1,AM2,AM3,AM4,IP1,IP2)
15423         ELSE IF(NCODE(I).EQ.5) THEN
15424           CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15425      &                AM1,AM2)
15426           AM3 = 0.D0
15427           AM4 = 0.D0
15428           IP1 = 0
15429           IP2 = 0
15430         ELSE IF(NCODE(I).EQ.7) THEN
15431           GOTO 99
15432         ELSE IF(NCODE(I).LT.0) THEN
15433           GOTO 99
15434         ELSE
15435           WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15436      &                            J1,NCODE(I)
15437           CALL PHO_ABORT
15438         ENDIF
15439         IF(IDEB(83).GE.5)
15440      &    WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15441      &      'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15442      &      I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15443 C  select masses to correct
15444         IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15445           DO 200 K=1,ISTRO
15446             IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15447               J2 = NPOS(1,K)
15448 C  join quarks to gluon
15449               IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15450 C  flavour check
15451                 IFL1 = 0
15452                 IFL2 = 0
15453                 PROB1 = 0.D0
15454                 PROB2 = 0.D0
15455                 KK1 = NPOS(2,I)
15456                 KK2 = NPOS(2,K)
15457                 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15458                   CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15459      &                   -(PHEP(1,KK1)+PHEP(1,KK2))**2
15460      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15461      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15462                   IFL1 = ABS(IDHEP(KK1))
15463                   IF(IFL1.GT.2) THEN
15464                     PROB1 = 0.1D0/MAX(CMASS,EPS)
15465                   ELSE
15466                     PROB1 = 0.9D0/MAX(CMASS,EPS)
15467                   ENDIF
15468                 ENDIF
15469                 KK1 = ABS(NPOS(3,I))
15470                 KK2 = ABS(NPOS(3,K))
15471                 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15472                   CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15473      &                   -(PHEP(1,KK1)+PHEP(1,KK2))**2
15474      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15475      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15476                   IFL2 = ABS(IDHEP(KK1))
15477                   IF(IFL2.GT.2) THEN
15478                     PROB2 = 0.1D0/MAX(CMASS,EPS)
15479                   ELSE
15480                     PROB2 = 0.9D0/MAX(CMASS,EPS)
15481                   ENDIF
15482                 ENDIF
15483                 IF(IFL1+IFL2.EQ.0) GOTO 99
15484 C  fusion possible
15485                 ICCOR = ICCOR+1
15486                 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15487                   JJ = 2
15488                   JE = 3
15489                 ELSE
15490                   JJ = 3
15491                   JE = 2
15492                 ENDIF
15493                 KK1 = ABS(NPOS(JJ,I))
15494                 KK2 = ABS(NPOS(JJ,K))
15495                 I1 = ABS(NPOS(JE,I))
15496                 I2 = KK1
15497                 IS = SIGN(1,I2-I1)
15498                 I2 = I2 - IS
15499                 K1 = KK2
15500                 K2 = ABS(NPOS(JE,K))
15501                 KS = SIGN(1,K2-K1)
15502                 K1 = K1 + KS
15503                 IP1 = NHEP+1
15504 C  copy mother partons of string I
15505                 DO 300 II=I1,I2,IS
15506                   CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15507      &              PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15508      &              ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15509  300            CONTINUE
15510 C  register gluon
15511                 DO 350 II=1,4
15512                   PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15513  350            CONTINUE
15514                 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15515      &            I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15516 C  copy mother partons of string K
15517                 DO 400 II=K1,K2,KS
15518                   CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15519      &              PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15520      &              ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15521  400            CONTINUE
15522 C  create new string entry
15523                 DO 450 II=1,4
15524                   PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15525  450            CONTINUE
15526                 IP2 = IPOS
15527                 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15528      &            PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15529      &            ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15530 C  delete string K in /POSTRG/
15531                 NCODE(K) = -999
15532 C  update string I in /POSTRG/
15533                 NPOS(1,I) = IPOS
15534                 NPOS(2,I) = IP1
15535                 NPOS(3,I) = -IP2
15536 C  calculate new CPC string codes
15537                 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15538      &            IPAR2(I),IPAR3(I),IPAR4(I))
15539                 GOTO 99
15540               ENDIF
15541             ENDIF
15542  200      CONTINUE
15543         ENDIF
15544  99     CONTINUE
15545  100  CONTINUE
15546       IF(IDEB(83).GE.20) THEN
15547         WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15548         IF(IDEB(83).GE.22) THEN
15549           CALL PHO_PRSTRG
15550           CALL PHO_PREVNT(0)
15551         ENDIF
15552       ENDIF
15553
15554       END
15555
15556 *$ CREATE PHO_MASCOR.FOR
15557 *COPY PHO_MASCOR
15558 CDECK  ID>, PHO_MASCOR
15559       SUBROUTINE PHO_MASCOR(IREJ)
15560 C********************************************************************
15561 C
15562 C    check and adjust parton momenta for fragmentation
15563 C
15564 C    input:      /POEVT1/
15565 C                /POSTRG/
15566 C                IREJ    -1          initialization
15567 C                        -2          output of statistics
15568 C
15569 C    output:     /POEVT1/
15570 C                /POSTRG/
15571 C                IREJ    0  successful
15572 C                        1  failure
15573 C
15574 C    in case of very small string mass:
15575 C       - direct manipulation of /POEVT1/ and /POEVT2/
15576 C       - string will be deleted from /POSTRG/ (label -99)
15577 C
15578 C********************************************************************
15579       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15580       SAVE
15581
15582       PARAMETER ( EPS    =  1.D-10,
15583      &            EMIN   =  0.3D0,
15584      &            DEPS   =  1.D-15)
15585
15586 C  input/output channels
15587       INTEGER LI,LO
15588       COMMON /POINOU/ LI,LO
15589 C  event debugging information
15590       INTEGER NMAXD
15591       PARAMETER (NMAXD=100)
15592       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15593      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15594       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15595      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15596 C  internal rejection counters
15597       INTEGER NMXJ
15598       PARAMETER (NMXJ=60)
15599       CHARACTER*10 REJTIT
15600       INTEGER IFAIL
15601       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15602 C  model switches and parameters
15603       CHARACTER*8 MDLNA
15604       INTEGER ISWMDL,IPAMDL
15605       DOUBLE PRECISION PARMDL
15606       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15607 C  standard particle data interface
15608       INTEGER NMXHEP
15609       PARAMETER (NMXHEP=4000)
15610       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15611       DOUBLE PRECISION PHEP,VHEP
15612       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15613      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15614      &                VHEP(4,NMXHEP)
15615 C  extension to standard particle data interface (PHOJET specific)
15616       INTEGER IMPART,IPHIST,ICOLOR
15617       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15618 C  color string configurations including collapsed strings and hadrons
15619       INTEGER MSTR
15620       PARAMETER (MSTR=500)
15621       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15622       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15623      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15624      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15625
15626       DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15627
15628       IF(IREJ.EQ.-1) THEN
15629         ICTOT = 0
15630         ICCOR = 0
15631         RETURN
15632       ELSE IF(IREJ.EQ.-2) THEN
15633         WRITE(LO,'(/1X,A,2I8/)')
15634      &    'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15635         RETURN
15636       ENDIF
15637
15638       IREJ = 0
15639       NITER = 100
15640       ITER = 0
15641       ICTOT = ICTOT+ISTR
15642       IF(ISWMDL(7).EQ.-1) RETURN
15643 C  debug /POSTRG/
15644       IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15645
15646       ITOUCH = 0
15647  50   CONTINUE
15648       ITER = ITER+1
15649       IF(ITER.GE.NITER) THEN
15650         IREJ = 1
15651         IF(IDEB(42).GE.2) THEN
15652           WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15653           IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15654         ENDIF
15655         RETURN
15656       ENDIF
15657
15658 C  check mass limits
15659       IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15660         IM1 = 1
15661         IM2 = ISTR
15662         IST = 1
15663       ELSE
15664         IM1 = ISTR
15665         IM2 = 1
15666         IST = -1
15667       ENDIF
15668       DO 100 I=IM1,IM2,IST
15669         J1 = NPOS(1,I)
15670         CMASS0 = PHEP(5,J1)
15671 C  get masses
15672         IF(NCODE(I).EQ.3) THEN
15673           CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15674         ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15675           CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15676      &                AM1,AM2,AM3,AM4,IP1,IP2)
15677         ELSE IF(NCODE(I).EQ.5) THEN
15678           CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15679      &              AM1,AM2)
15680           AM3 = 0.D0
15681           AM4 = 0.D0
15682           IP1 = 0
15683           IP2 = 0
15684         ELSE IF(NCODE(I).EQ.7) THEN
15685           AM1 = 0.15D0
15686           AM2 = 0.3D0
15687           AM3 = 0.765D0
15688           AM4 = 1.5D0
15689 *??????????????????????????????????
15690           IP1 = 23
15691           IP2 = 33
15692 *??????????????????????????????????
15693         ELSE IF(NCODE(I).LT.0) THEN
15694           GOTO 90
15695         ELSE
15696           WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15697      &                            J1,NCODE(I)
15698           CALL PHO_ABORT
15699         ENDIF
15700         IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15701      &    'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15702      &    I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15703 C  select masses to correct
15704         IBHAD(I) = 0
15705         NNCH(I) = 0
15706 C  correction needed?
15707 C  no resonances for diquark-antidiquark and gluon-gluon strings
15708         IF(NCODE(I).EQ.5) THEN
15709           IF(CMASS0.LT.1.3D0*AM1) THEN
15710             IF(ISWMDL(7).LE.2) THEN
15711               IBHAD(I) = 90
15712               NNCH(I)  = -1
15713               CHMASS   = AM1*1.3D0
15714             ELSE
15715               IREJ = 1
15716               RETURN
15717             ENDIF
15718           ENDIF
15719         ELSE
15720           INEED = 0
15721 C  resonances possible
15722           IF(ISWMDL(7).EQ.0) THEN
15723             IF(CMASS0.LT.AM1*0.99D0) THEN
15724               IBHAD(I) = IP1
15725               NNCH(I)  = -1
15726               CHMASS   = AM1
15727               INEED = 1
15728             ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15729               DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15730               DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15731               IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15732                 IBHAD(I) = IP1
15733                 NNCH(I)  = -1
15734                 CHMASS   = AM1
15735               ELSE
15736                 IBHAD(I) = IP2
15737                 NNCH(I)  = 1
15738                 CHMASS   = AM3
15739               ENDIF
15740             ENDIF
15741           ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15742             IF(CMASS0.LT.AM1*0.99) THEN
15743               IBHAD(I) = IP1
15744               NNCH(I) = -1
15745               CHMASS = AM1
15746               INEED = 1
15747             ENDIF
15748           ELSE IF(ISWMDL(7).EQ.3) THEN
15749             IF(CMASS0.LT.AM1) THEN
15750               IREJ = 1
15751               RETURN
15752             ENDIF
15753           ELSE
15754             WRITE(LO,'(/1X,A,I5)')
15755      &        'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15756             CALL PHO_ABORT
15757           ENDIF
15758         ENDIF
15759 C
15760 C  correction necessary?
15761         IF(IBHAD(I).NE.0) THEN
15762 C  find largest invar. mass
15763           IPOS = 0
15764           CMASS1 = -1.D0
15765           DO 200 J2=NHEP,3,-1
15766             IF(ABS(ISTHEP(J2)).EQ.1) THEN
15767               IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15768                 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15769      &            'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15770                 CALL PHO_PREVNT(0)
15771               ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15772                 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15773      &                 -(PHEP(1,J1)+PHEP(1,J2))**2
15774      &                 -(PHEP(2,J1)+PHEP(2,J2))**2
15775      &                 -(PHEP(3,J1)+PHEP(3,J2))**2
15776                 IF(CMASS2.GT.CMASS1) THEN
15777                   IPOS=J2
15778                   CMASS1=CMASS2
15779                 ENDIF
15780               ENDIF
15781             ENDIF
15782  200      CONTINUE
15783           J2 = IPOS
15784           IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15785             IF(INEED.EQ.1) THEN
15786               IREJ = 1
15787               RETURN
15788             ELSE
15789               IBHAD(I) = 0
15790               NNCH(I) = 0
15791               GOTO 90
15792             ENDIF
15793           ENDIF
15794           ISTA = ISTHEP(J1)
15795           ISTB = ISTHEP(J2)
15796           CMASS1 = SQRT(CMASS1)
15797           CMASS2 = PHEP(5,J2)
15798           IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15799           IREJ = 1
15800           IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15801      &      CHMASS,CMASS2,PC1,PC2,IREJ)
15802           IF(IREJ.NE.0) THEN
15803             IFAIL(24) = IFAIL(24)+1
15804             IF(IDEB(42).GE.2) THEN
15805               WRITE(LO,'(1X,A,2I4)')
15806      &          'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15807               IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15808             ENDIF
15809             IREJ = 1
15810             RETURN
15811           ENDIF
15812 C  momentum transfer
15813           DO 210 II=1,4
15814             PTR(II) = PHEP(II,J2)-PC2(II)
15815  210      CONTINUE
15816           IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15817      &      'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15818 C  copy parents of strings
15819 C  register partons belonging to first string
15820           IF(IDHEP(J1).EQ.90) THEN
15821             K1 = JMOHEP(1,J1)
15822             K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15823             ESUM = 0.D0
15824             DO 500 II=K1,K2
15825               ESUM = ESUM+PHEP(4,II)
15826  500        CONTINUE
15827             IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15828             DO 600 II=K1,K2
15829               FAC = PHEP(4,II)/ESUM
15830               DO 650 K=1,4
15831                 P1(K) = PHEP(K,II)+FAC*PTR(K)
15832  650          CONTINUE
15833               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15834      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15835      &          ICOLOR(2,II),IPOS,1)
15836  600        CONTINUE
15837             K1A = IPOS+K1-K2
15838             IF(JMOHEP(2,J1).GT.0) THEN
15839               II = JMOHEP(2,J1)
15840               FAC = PHEP(4,II)/ESUM
15841               DO 675 K=1,4
15842                 P1(K) = PHEP(K,II)+FAC*PTR(K)
15843  675          CONTINUE
15844               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15845      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15846      &          ICOLOR(2,II),IPOS,1)
15847             ENDIF
15848             K2A = -IPOS
15849           ELSE
15850             K1A = J1
15851             K2A = J2
15852           ENDIF
15853 C  register partons belonging to second string
15854           IF(IDHEP(J2).EQ.90) THEN
15855             CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15856             K1 = JMOHEP(1,J2)
15857             K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15858             ESUM = 0.D0
15859             DO 300 II=K1,K2
15860               ESUM = ESUM+PHEP(4,II)
15861  300        CONTINUE
15862             IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15863             DO 400 II=K1,K2
15864 **sr 28.12.2006 fix adopted from FLUKA
15865 C             FAC = PHEP(4,II)/ESUM
15866               IF (ABS(ESUM).GT.0.D0) THEN
15867                  FAC = PHEP(4,II)/ESUM
15868               ELSE
15869                  FAC = 1.0D0
15870               ENDIF
15871 **
15872               IF(IREJL.EQ.0) THEN
15873                 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15874                 P1(4) = P1(4)+FAC*DELE
15875               ELSE
15876                 DO 450 K=1,4
15877                   P1(K) = PHEP(K,II)-FAC*PTR(K)
15878  450            CONTINUE
15879               ENDIF
15880               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15881      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15882      &          ICOLOR(2,II),IPOS,1)
15883  400        CONTINUE
15884             K1B = IPOS+K1-K2
15885             IF(JMOHEP(2,J2).GT.0) THEN
15886               II = JMOHEP(2,J2)
15887               FAC = PHEP(4,II)/ESUM
15888               IF(IREJL.EQ.0) THEN
15889                 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15890                 P1(4) = P1(4)+FAC*DELE
15891               ELSE
15892                 DO 475 K=1,4
15893                   P1(K) = PHEP(K,II)-FAC*PTR(K)
15894  475            CONTINUE
15895               ENDIF
15896               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15897      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15898      &          ICOLOR(2,II),IPOS,1)
15899             ENDIF
15900             K2B = -IPOS
15901           ELSE
15902             K1B = J1
15903             K2B = J2
15904           ENDIF
15905 C  register first string/collapsed to hadron
15906           IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
15907             IF(NCODE(I).NE.5) THEN
15908               CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
15909      &          PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15910 C  label string as collapsed to hadron/resonance
15911               NCODE(I)  = -99
15912               IDHEP(J1) = 92
15913             ELSE
15914               CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
15915      &          PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15916               IDHEP(J1) = 91
15917             ENDIF
15918             NPOS(1,I) = IPOS
15919             NPOS(2,I) = K1A
15920             NPOS(3,I) = K2A
15921           ELSE
15922             CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
15923      &        PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
15924      &        ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
15925             IF(IDHEP(J1).EQ.90) THEN
15926               NPOS(1,IPHIST(1,J1)) = IPOS
15927               NPOS(2,IPHIST(1,J1)) = K1A
15928               NPOS(3,IPHIST(1,J1)) = K2A
15929 C  label string as collapsed to resonance-string
15930               IDHEP(J1) = 91
15931             ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
15932               IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
15933             ENDIF
15934           ENDIF
15935 C  register second string/hadron/parton
15936           CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
15937      &      PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
15938      &      ICOLOR(2,J2),IPOS,1)
15939           IF(IDHEP(J2).EQ.90) THEN
15940             NPOS(1,IPHIST(1,J2))=IPOS
15941             NPOS(2,IPHIST(1,J2))=K1B
15942             NPOS(3,IPHIST(1,J2))=K2B
15943 C  label string touched by momentum transfer
15944             IDHEP(J2) = 91
15945           ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
15946             IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
15947           ENDIF
15948           ICCOR = ICCOR+1
15949           ITOUCH = ITOUCH+1
15950 C  consistency checks
15951           IF(IDEB(42).GE.5) THEN
15952             CALL PHO_CHECK(-1,IDEV)
15953             IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
15954           ENDIF
15955 C  jump to next iteration
15956           GOTO 50
15957         ENDIF
15958  90     CONTINUE
15959  100  CONTINUE
15960 C  debug output
15961       IF(IDEB(42).GE.15) THEN
15962         IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
15963           WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
15964           CALL PHO_PREVNT(1)
15965         ENDIF
15966       ENDIF
15967       END
15968
15969 *$ CREATE PHO_PARCOR.FOR
15970 *COPY PHO_PARCOR
15971 CDECK  ID>, PHO_PARCOR
15972       SUBROUTINE PHO_PARCOR(MODE,IREJ)
15973 C********************************************************************
15974 C
15975 C    conversion of string partons (using JETSET masses)
15976 C
15977 C    input:      MODE    >0 position index of corresponding string
15978 C                        -1 initialization
15979 C                        -2 output of statistics
15980 C
15981 C    output:     /POSTRG/
15982 C                IREJ    1 combination of strings impossible
15983 C                        0 successful combination
15984 C
15985 C********************************************************************
15986       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15987       SAVE
15988
15989       PARAMETER ( DELM   =  0.005D0,
15990      &            DEPS   =  1.D-15,
15991      &            EPS    =  1.D-5)
15992
15993 C  input/output channels
15994       INTEGER LI,LO
15995       COMMON /POINOU/ LI,LO
15996 C  event debugging information
15997       INTEGER NMAXD
15998       PARAMETER (NMAXD=100)
15999       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16000      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16001       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16002      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16003 C  internal rejection counters
16004       INTEGER NMXJ
16005       PARAMETER (NMXJ=60)
16006       CHARACTER*10 REJTIT
16007       INTEGER IFAIL
16008       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16009 C  model switches and parameters
16010       CHARACTER*8 MDLNA
16011       INTEGER ISWMDL,IPAMDL
16012       DOUBLE PRECISION PARMDL
16013       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16014 C  standard particle data interface
16015       INTEGER NMXHEP
16016       PARAMETER (NMXHEP=4000)
16017       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16018       DOUBLE PRECISION PHEP,VHEP
16019       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16020      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16021      &                VHEP(4,NMXHEP)
16022 C  extension to standard particle data interface (PHOJET specific)
16023       INTEGER IMPART,IPHIST,ICOLOR
16024       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16025 C  color string configurations including collapsed strings and hadrons
16026       INTEGER MSTR
16027       PARAMETER (MSTR=500)
16028       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16029       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16030      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16031      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16032
16033       DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16034      &          PL(4,100),XMP(100),XML(100)
16035
16036       DOUBLE PRECISION PYMASS
16037
16038       IREJ = 0
16039       IMODE = MODE
16040 C
16041       IF(IMODE.GT.0) THEN
16042         ICH = 0
16043         I1 = JMOHEP(1,IMODE)
16044         I2 = ABS(JMOHEP(2,IMODE))
16045 C  copy to local field
16046         L = 0
16047         DO 100 I=I1,I2
16048           L = L+1
16049           DO 200 K=1,4
16050             PL(K,L) = PHEP(K,I)
16051  200      CONTINUE
16052           XMP(L) = PHEP(5,I)
16053           XML(L) = PYMASS(IDHEP(I))
16054  100    CONTINUE
16055         IPAR = L
16056         XMC = PHEP(5,IMODE)
16057         IF(IDEB(82).GE.20) THEN
16058           WRITE(LO,'(1X,A,I7,2I4)')
16059      &      'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16060      &      KEVENT,IMODE,L
16061           DO 150 I=1,L
16062             WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16063      &       XMP(I),XML(I)
16064  150      CONTINUE
16065         ENDIF
16066 C
16067 C  two parton configurations
16068 C  -----------------------------------------
16069         IF(IPAR.EQ.2) THEN
16070           XM1 = XML(1)
16071           XM2 = XML(2)
16072           IF((XM1+XM2).GE.XMC) THEN
16073             IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16074      &        'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16075      &        IMODE,XM1,XM2,XMC
16076             GOTO 990
16077           ENDIF
16078 C  conversion possible
16079           CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16080           IF(IREJ.NE.0) THEN
16081             IFAIL(36) = IFAIL(36)+1
16082             IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16083      &      'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16084      &        KEVENT,IMODE,XMC
16085             GOTO 990
16086           ENDIF
16087           ICH = 1
16088           DO 115 K=1,4
16089             PL(K,1) = PP1(K)
16090             PL(K,2) = PP2(K)
16091             XMP(1) = XM1
16092             XMP(2) = XM2
16093  115      CONTINUE
16094 C
16095 C  multi parton configurations
16096 C  ---------------------------------
16097         ELSE
16098 C
16099 C  random selection of string side to start with
16100           IF(DT_RNDM(XMC).LT.0.5D0) THEN
16101             K1 = 1
16102             K2 = IPAR
16103             KS = 1
16104           ELSE
16105             K1 = IPAR
16106             K2 = 1
16107             KS = -1
16108           ENDIF
16109           ITER = 0
16110 C
16111  300      CONTINUE
16112           IF(ITER.LT.4) THEN
16113             KK = K1
16114             K1 = K2
16115             K2 = KK
16116             KS = -KS
16117           ELSE
16118             GOTO 990
16119           ENDIF
16120           ITER = ITER+1
16121 C  select method
16122           IF(ITER.GT.2) GOTO 230
16123
16124 C  conversion according to color flow method
16125           IFAI = 0
16126           DO 210 II=K1,K2-KS,KS
16127             DO 215 IK=II+KS,K2,KS
16128               XM1 = XML(II)
16129               XM2 = XML(IK)
16130 *             IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16131 *    &          'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16132               IF((ABS(XM1-XMP(II)).GT.DELM)
16133      &           .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16134                 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16135                 IF(IREJ.NE.0) THEN
16136                   IFAIL(36) = IFAIL(36)+1
16137                   IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16138      &              'PHO_PARCOR: ',
16139      &              'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16140      &              KEVENT,IMODE,II,IK
16141                   IREJ = 0
16142                 ELSE
16143                   ICH = ICH+1
16144                   DO 220 KK=1,4
16145                     PL(KK,II) = PP1(KK)
16146                     PL(KK,IK) = PP2(KK)
16147  220              CONTINUE
16148                   XMP(II) = XM1
16149                   XMP(IK) = XM2
16150                   GOTO 219
16151                 ENDIF
16152               ELSE
16153                 GOTO 219
16154               ENDIF
16155  215        CONTINUE
16156             IFAI = II
16157  219        CONTINUE
16158  210      CONTINUE
16159           IF(IFAI.NE.0) GOTO 300
16160           GOTO 950
16161 C
16162  230      CONTINUE
16163 C
16164 C  conversion according to remainder method
16165           DO 350 I=K1,K2,KS
16166             XM1 = XML(I)
16167             IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16168               ICH = ICH+1
16169               IFAI = I
16170 C  conversion necessary
16171               DO 400 K=1,4
16172                 PB1(K) = PL(K,I)
16173                 PB2(K) = PHEP(K,IMODE)-PB1(K)
16174  400          CONTINUE
16175               XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16176               IF(XM2.LT.0.D0) THEN
16177                 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16178      &            'PHO_PARCOR: ',
16179      &            'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16180      &            I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16181                 GOTO 300
16182               ENDIF
16183               XM2 = SQRT(XM2)
16184               IF((XM1+XM2).GE.XMC) THEN
16185                 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16186      &            'PHO_PARCOR: ',
16187      &            'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16188      &            I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16189                 GOTO 300
16190               ENDIF
16191 C  conversion possible
16192               CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16193               IF(IREJ.NE.0) THEN
16194                 IFAIL(36) = IFAIL(36)+1
16195                 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16196      &            'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16197      &            ITER,IMODE,I
16198                 GOTO 300
16199               ENDIF
16200 C  calculate Lorentz transformation
16201               CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16202               IF(IREJ.NE.0) THEN
16203                 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16204      &            'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16205      &            ITER,IMODE,I
16206                 GOTO 300
16207               ENDIF
16208               IFAI = 0
16209 C  transform remaining partons
16210               DO 450 L=K1,K2,KS
16211                 IF(L.NE.I) THEN
16212                   CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16213                   DO 500 K=1,4
16214                     PL(K,L) = PP2(K)
16215  500              CONTINUE
16216                 ELSE
16217                   DO 550 K=1,4
16218                     PL(K,L) = PP1(K)
16219  550              CONTINUE
16220                 ENDIF
16221  450          CONTINUE
16222               XMP(I) = XM1
16223             ENDIF
16224  350      CONTINUE
16225         ENDIF
16226
16227 C  register transformed partons
16228  950      CONTINUE
16229           IREJ = 0
16230           IF(ICH.NE.0) THEN
16231             IP1 = NHEP+1
16232             L = 0
16233             DO 700 I=I1,I2
16234               L= L+1
16235               CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16236      &          PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16237      &          ICOLOR(2,I),IPOS,1)
16238  700        CONTINUE
16239             IP2 = IPOS
16240 C  register string
16241             CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16242      &        PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16243      &        IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16244 C  update /POSTRG/
16245             I = IPHIST(1,IMODE)
16246             NPOS(1,I) = IPOS
16247             NPOS(2,I) = IP1
16248             NPOS(3,I) = -IP2
16249           ENDIF
16250 C  debug output
16251           IF(IDEB(82).GE.20) THEN
16252             WRITE(LO,'(1X,A,I7,2I4)')
16253      &        'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16254      &        KEVENT,IMODE,L
16255             DO 850 I=1,L
16256               WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16257      &         XMP(I),XML(I)
16258  850        CONTINUE
16259             WRITE(LO,'(1X,A,2I5)')
16260      &        'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16261           ENDIF
16262           RETURN
16263 C  rejection
16264  990      CONTINUE
16265           IREJ = 1
16266           IF(IDEB(82).GE.3) THEN
16267             WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16268      &        'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16269      &         IFAI,IPAR,IMODE,XMC
16270             IF(IDEB(82).GE.5) THEN
16271               WRITE(LO,'(1X,A,I7,2I4)')
16272      &          'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16273      &          KEVENT,IMODE,IPAR
16274               DO 155 I=1,IPAR
16275                 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16276      &           XMP(I),XML(I)
16277  155          CONTINUE
16278             ENDIF
16279           ENDIF
16280           RETURN
16281
16282       ELSE IF(IMODE.EQ.-1) THEN
16283 C  initialization
16284         RETURN
16285
16286       ELSE IF(IMODE.EQ.-2) THEN
16287 C  final output
16288         RETURN
16289       ENDIF
16290       END
16291
16292 *$ CREATE PHO_STRING.FOR
16293 *COPY PHO_STRING
16294 CDECK  ID>, PHO_STRING
16295       SUBROUTINE PHO_STRING(IMODE,IREJ)
16296 C********************************************************************
16297 C
16298 C    calculation of string combinatorics, Lorentz boosts and
16299 C                   particle codes
16300 C
16301 C                - splitting of gluons
16302 C                - strings will be built up from pairs of partons
16303 C                  according to their color labels
16304 C                  with IDHEP(..) = -1
16305 C                - there can be other particles between to string partons
16306 C                  (these will be unchanged by string construction)
16307 C                - string mass fine correction
16308 C
16309 C    input:      IMODE    1  complete string processing
16310 C                        -1 initialization
16311 C                        -2 output of statistics
16312 C
16313 C    output:     /POSTRG/
16314 C                IREJ    1 combination of strings impossible
16315 C                        0 successful combination
16316 C                       50 rejection due to user cutoffs
16317 C
16318 C********************************************************************
16319       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16320       SAVE
16321
16322       PARAMETER ( DEPS   =  1.D-15,
16323      &            EPS    =  1.D-5 )
16324
16325 C  input/output channels
16326       INTEGER LI,LO
16327       COMMON /POINOU/ LI,LO
16328 C  event debugging information
16329       INTEGER NMAXD
16330       PARAMETER (NMAXD=100)
16331       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16332      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16333       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16334      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16335 C  general process information
16336       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16337       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16338 C  internal rejection counters
16339       INTEGER NMXJ
16340       PARAMETER (NMXJ=60)
16341       CHARACTER*10 REJTIT
16342       INTEGER IFAIL
16343       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16344 C  model switches and parameters
16345       CHARACTER*8 MDLNA
16346       INTEGER ISWMDL,IPAMDL
16347       DOUBLE PRECISION PARMDL
16348       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16349 C  hard cross sections and MC selection weights
16350       INTEGER Max_pro_2
16351       PARAMETER ( Max_pro_2 = 16 )
16352       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16353      &  MH_acc_1,MH_acc_2
16354       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16355       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16356      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16357      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16358      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16359      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16360 C  standard particle data interface
16361       INTEGER NMXHEP
16362       PARAMETER (NMXHEP=4000)
16363       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16364       DOUBLE PRECISION PHEP,VHEP
16365       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16366      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16367      &                VHEP(4,NMXHEP)
16368 C  extension to standard particle data interface (PHOJET specific)
16369       INTEGER IMPART,IPHIST,ICOLOR
16370       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16371 C  color string configurations including collapsed strings and hadrons
16372       INTEGER MSTR
16373       PARAMETER (MSTR=500)
16374       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16375       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16376      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16377      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16378 C  table of particle indices for recursive PHOJET calls
16379       INTEGER MAXIPX
16380       PARAMETER ( MAXIPX = 100 )
16381       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16382       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16383      &                IPOIX1,IPOIX2,IPOIX3
16384 C  some constants
16385       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16386       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16387      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16388
16389       IREJ = 0
16390       IF(IMODE.EQ.-1) THEN
16391         CALL PHO_POMCOR(-1)
16392         CALL PHO_MASCOR(-1)
16393         CALL PHO_PARCOR(-1,IREJ)
16394         RETURN
16395       ELSE IF(IMODE.EQ.-2) THEN
16396         CALL PHO_POMCOR(-2)
16397         CALL PHO_MASCOR(-2)
16398         CALL PHO_PARCOR(-2,IREJ)
16399         RETURN
16400       ENDIF
16401
16402 C  generate enhanced graphs
16403       IF(IPOIX2.GT.0) THEN
16404  200    CONTINUE
16405         I1 = MAX(1,IPOIX1)
16406         I2 = IPOIX2
16407         IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16408         KSPOMS = KSPOM-1
16409         KSREGS = KSREG
16410         KHPOMS = KHPOM
16411         KHDIRS = KHDIR
16412         IDDFS1 = IDIFR1
16413         IDDFS2 = IDIFR2
16414         IDDPOS = IDDPOM
16415         DO 110 I=I1,I2
16416           IPOIX3 = I
16417           KSPOM = 0
16418           KSREG = 0
16419           KHPOM = 0
16420           KHDIR = 0
16421           IF(IPORES(I).EQ.8) THEN
16422             KSPOM = 2
16423             LSPOM = 2
16424             LHPOM = 0
16425             LSREG = 0
16426             LHDIR = 0
16427             IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16428             CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16429      &                      LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16430             IF(IREJ.NE.0) THEN
16431               IF(IDEB(4).GE.2) THEN
16432                 WRITE(LO,'(/1X,A,I5)')
16433      &            'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16434                 CALL PHO_PREVNT(-1)
16435               ENDIF
16436               RETURN
16437             ENDIF
16438             KSPOM = KSPOMS+LSPOM
16439             KSREG = KSREGS+LSREG
16440             KHPOM = KHPOMS+LHPOM
16441             KHDIR = KHDIRS+LHDIR
16442           ELSE IF(IPORES(I).EQ.4) THEN
16443             ITEMP = ISWMDL(17)
16444             ISWMDL(17) = 0
16445             CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16446             ISWMDL(17) = ITEMP
16447             IF(IREJ.NE.0) THEN
16448               IF(IDEB(4).GE.2) THEN
16449                 WRITE(LO,'(/1X,A,I5)')
16450      &            'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16451                 CALL PHO_PREVNT(-1)
16452               ENDIF
16453               RETURN
16454             ENDIF
16455             KSDPO = KSDPO+1
16456             KSPOM = KSPOMS+KSPOM
16457             KSREG = KSREGS+KSREG
16458             KHPOM = KHPOMS+KHPOM
16459             KHDIR = KHDIRS+KHDIR
16460           ELSE
16461             IDIF1 = 1
16462             IDIF2 = 1
16463             IF(IPORES(I).EQ.5) THEN
16464               IDIF2 = 0
16465               KSTRG = KSTRG+1
16466             ELSE IF(IPORES(I).EQ.6) THEN
16467               IDIF1 = 0
16468               KSTRG = KSTRG+1
16469             ELSE
16470               KSLOO = KSLOO+1
16471             ENDIF
16472             ITEMP = ISWMDL(16)
16473             ISWMDL(16) = 0
16474             SPROB = 1.D0
16475             CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16476      &        0,MSOFT,MHARD,IREJ)
16477             ISWMDL(16) = ITEMP
16478             IF(IREJ.NE.0) THEN
16479               IF(IDEB(4).GE.2) THEN
16480                 WRITE(LO,'(/1X,A,I5)')
16481      &            'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16482                 CALL PHO_PREVNT(-1)
16483               ENDIF
16484               RETURN
16485             ENDIF
16486             KSPOM = KSPOMS+KSPOM
16487             KSREG = KSREGS+KSREG
16488             KHPOM = KHPOMS+KHPOM
16489             KHDIR = KHDIRS+KHDIR
16490           ENDIF
16491           IDIFR1 = IDDFS1
16492           IDIFR2 = IDDFS2
16493           IDDPOM = IDDPOS
16494  110    CONTINUE
16495         IF(IPOIX2.GT.I2) THEN
16496           IPOIX1 = I2+1
16497           GOTO 200
16498         ENDIF
16499       ENDIF
16500
16501 C  optional: split gluons to q-qbar pairs
16502       IF(ISWMDL(9).GT.0) THEN
16503         NHEPO = NHEP
16504         DO 30 I=3,NHEPO
16505           IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16506             ICG1=ICOLOR(1,I)
16507             ICG2=ICOLOR(2,I)
16508             IQ1 = 0
16509             IQ2 = 0
16510             DO 40 K=3,NHEPO
16511               IF(ICOLOR(1,K).EQ.-ICG1) THEN
16512                 IQ1 = K
16513                 IF(IQ1*IQ2.NE.0) GOTO 45
16514               ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16515                 IQ2 = K
16516                 IF(IQ1*IQ2.NE.0) GOTO 45
16517               ENDIF
16518  40         CONTINUE
16519             WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16520      &        'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16521             CALL PHO_ABORT
16522  45         CONTINUE
16523             CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16524             IF(IREJ.NE.0) THEN
16525               IF(IDEB(19).GE.5) THEN
16526                 WRITE(LO,'(/,1X,A)')
16527      &            'PHO_STRING: no gluon splitting possible'
16528                 CALL PHO_PREVNT(0)
16529               ENDIF
16530               RETURN
16531             ENDIF
16532           ENDIF
16533  30     CONTINUE
16534       ENDIF
16535
16536 C  construct strings and write entries sorted by strings
16537
16538       ISTR = ISTR+1
16539       NHEPO = NHEP
16540       DO 50 I=3,NHEPO
16541         IF(ISTR.GT.MSTR) THEN
16542           WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16543      &      'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16544           CALL PHO_PREVNT(0)
16545           IREJ = 1
16546           RETURN
16547         ENDIF
16548         IF(ISTHEP(I).EQ.1) THEN
16549 C  hadrons / resonances / clusters
16550           NPOS(1,ISTR) = I
16551           NPOS(2,ISTR) = 0
16552           NPOS(3,ISTR) = 0
16553           NPOS(4,ISTR) = abs(IPHIST(2,I))
16554           NCODE(ISTR) = -99
16555           IPHIST(1,I) = ISTR
16556           ISTR = ISTR+1
16557         ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16558 C  quark /diquark terminated strings
16559           ICOL1 = -ICOLOR(1,I)
16560           P1 = PHEP(1,I)
16561           P2 = PHEP(2,I)
16562           P3 = PHEP(3,I)
16563           P4 = PHEP(4,I)
16564           ICH1 = IPHO_CHR3(I,2)
16565           IBA1 = IPHO_BAR3(I,2)
16566           CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16567      &                P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16568      &                ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16569           JM1 = IPOS
16570
16571           NRPOM = 0
16572  65       CONTINUE
16573           DO 55 K=3,NHEPO
16574             IF(ISTHEP(K).EQ.-1)THEN
16575               IF(IDHEP(K).EQ.21) THEN
16576                 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16577                   ICOL1 = -ICOLOR(2,K)
16578                   GOTO 60
16579                 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16580                   ICOL1 = -ICOLOR(1,K)
16581                   GOTO 60
16582                 ENDIF
16583               ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16584                 ICOL1 = 0
16585                 GOTO 60
16586               ENDIF
16587             ENDIF
16588  55       CONTINUE
16589           WRITE(LO,'(/1X,A,I5)')
16590      &      'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16591           CALL PHO_ABORT
16592  60       CONTINUE
16593           P1 = P1+PHEP(1,K)
16594           P2 = P2+PHEP(2,K)
16595           P3 = P3+PHEP(3,K)
16596           P4 = P4+PHEP(4,K)
16597           NRPOM = MAX(NRPOM,IPHIST(1,K))
16598           ICH1 = ICH1+IPHO_CHR3(K,2)
16599           IBA1 = IBA1+IPHO_BAR3(K,2)
16600           CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16601      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16602      &      IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16603 C  further parton involved?
16604           IF(ICOL1.NE.0) GOTO 65
16605           JM2 = IPOS
16606 C  register string
16607           IGEN = IPHIST(2,K)
16608           CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16609      &                ISTR,IGEN,ICH1,IBA1,IPOS,1)
16610 C  store additional string information
16611           NPOS(1,ISTR) = IPOS
16612           NPOS(2,ISTR) = JM1
16613           NPOS(3,ISTR) = -JM2
16614           NPOS(4,ISTR) = abs(IPHIST(2,K))
16615 C  calculate CPC string codes
16616           CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16617      &                IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16618           ISTR = ISTR+1
16619         ENDIF
16620  50   CONTINUE
16621
16622       DO 150 I=3,NHEPO
16623         IF(ISTR.GT.MSTR) THEN
16624           WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16625      &      'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16626           CALL PHO_PREVNT(0)
16627           IREJ = 1
16628           RETURN
16629         ENDIF
16630         IF(ISTHEP(I).EQ.-1) THEN
16631 C  gluon loop-strings
16632           ICOL1 = -ICOLOR(1,I)
16633           P1 = PHEP(1,I)
16634           P2 = PHEP(2,I)
16635           P3 = PHEP(3,I)
16636           P4 = PHEP(4,I)
16637           IBA1 = 0
16638           ICH1 = 0
16639           CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16640      &                P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16641      &                ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16642           JM1 = IPOS
16643 C
16644           NRPOM = 0
16645  165      CONTINUE
16646           IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16647           DO 155 K=I,NHEPO
16648             IF(ISTHEP(K).EQ.-1)THEN
16649               IF(ICOLOR(1,K).EQ.ICOL1) THEN
16650                 ICOL1 = -ICOLOR(2,K)
16651                 GOTO 160
16652               ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16653                 ICOL1 = -ICOLOR(1,K)
16654                 GOTO 160
16655               ENDIF
16656             ENDIF
16657  155      CONTINUE
16658           WRITE(LO,'(/1X,A,I5)')
16659      &      'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16660           CALL PHO_ABORT
16661  160      CONTINUE
16662           P1 = P1+PHEP(1,K)
16663           P2 = P2+PHEP(2,K)
16664           P3 = P3+PHEP(3,K)
16665           P4 = P4+PHEP(4,K)
16666           NRPOM = MAX(NRPOM,IPHIST(1,K))
16667           CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16668      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16669      &      IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16670 C  further parton involved?
16671           IF(ICOL1.NE.0) GOTO 165
16672  170      CONTINUE
16673           JM2 = IPOS
16674 C  register string
16675           IGEN = IPHIST(2,K)
16676           CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16677      &                ISTR,IGEN,ICH1,IBA1,IPOS,1)
16678 C  store additional string information
16679           NPOS(1,ISTR) = IPOS
16680           NPOS(2,ISTR) = JM1
16681           NPOS(3,ISTR) = -JM2
16682           NPOS(4,ISTR) = abs(IPHIST(2,K))
16683 C  calculate CPC string codes
16684           CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16685      &                IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16686           ISTR = ISTR+1
16687         ENDIF
16688  150  CONTINUE
16689
16690       ISTR = ISTR-1
16691
16692       IF(IDEB(19).GE.17) THEN
16693         WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16694         CALL PHO_PREVNT(0)
16695       ENDIF
16696
16697 C  pomeron corrections
16698       CALL PHO_POMCOR(IREJ)
16699       IF(IREJ.NE.0) THEN
16700         IFAIL(38) = IFAIL(38)+1
16701         IF(IDEB(19).GE.3) THEN
16702           WRITE(LO,'(1X,A,I6)')
16703      &      'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16704           CALL PHO_PREVNT(-1)
16705         ENDIF
16706         RETURN
16707       ENDIF
16708
16709 C  string mass corrections
16710       CALL PHO_MASCOR(IREJ)
16711       IF(IREJ.NE.0) THEN
16712         IFAIL(34) = IFAIL(34)+1
16713         IF(IDEB(19).GE.3) THEN
16714           WRITE(LO,'(1X,A,I6)')
16715      &      'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16716           CALL PHO_PREVNT(-1)
16717         ENDIF
16718         RETURN
16719       ENDIF
16720
16721 C  parton mass corrections
16722       DO 100 I=1,ISTR
16723         IF(NCODE(I).GE.0) THEN
16724           CALL PHO_PARCOR(NPOS(1,I),IREJ)
16725           IF(IREJ.NE.0) THEN
16726             IFAIL(35) = IFAIL(35)+1
16727             IF(IDEB(19).GE.3) THEN
16728               WRITE(LO,'(1X,A,I6)')
16729      &          'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16730               CALL PHO_PREVNT(-1)
16731             ENDIF
16732             RETURN
16733           ENDIF
16734         ENDIF
16735  100  CONTINUE
16736
16737 C  statistics of hard processes
16738       DO 550 I=3,NHEP
16739         IF(ISTHEP(I).EQ.25) THEN
16740           K  = IMPART(I)
16741           II = IDHEP(I)
16742           MH_acc_2(K,II) = MH_acc_2(K,II)+1
16743         ENDIF
16744  550  CONTINUE
16745
16746 C  debug: write out strings
16747       IF(IDEB(19).GE.5) THEN
16748         IF(IDEB(19).GE.10)
16749      &    CALL PHO_CHECK(1,IDEV)
16750         IF(IDEB(19).GE.15) THEN
16751           CALL PHO_PREVNT(0)
16752         ELSE
16753           CALL PHO_PRSTRG
16754         ENDIF
16755       ENDIF
16756
16757       END
16758
16759 *$ CREATE PHO_STRFRA.FOR
16760 *COPY PHO_STRFRA
16761 CDECK  ID>, PHO_STRFRA
16762       SUBROUTINE PHO_STRFRA(IREJ)
16763 C********************************************************************
16764 C
16765 C     do all fragmentation of strings
16766 C
16767 C     output:  IREJ    0   successful
16768 C                      1   rejection
16769 C                     50   rejection due to user cutoffs
16770 C
16771 C********************************************************************
16772       IMPLICIT NONE
16773       SAVE
16774
16775 C  input/output channels
16776       INTEGER LI,LO
16777       COMMON /POINOU/ LI,LO
16778 C  some constants
16779       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16780       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16781      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16782 C  event debugging information
16783       INTEGER NMAXD
16784       PARAMETER (NMAXD=100)
16785       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16786      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16787       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16788      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16789 C  general process information
16790       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16791       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16792 C  model switches and parameters
16793       CHARACTER*8 MDLNA
16794       INTEGER ISWMDL,IPAMDL
16795       DOUBLE PRECISION PARMDL
16796       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16797 C  global event kinematics and particle IDs
16798       INTEGER IFPAP,IFPAB
16799       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16800       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16801 C  standard particle data interface
16802       INTEGER NMXHEP
16803       PARAMETER (NMXHEP=4000)
16804       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16805       DOUBLE PRECISION PHEP,VHEP
16806       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16807      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16808      &                VHEP(4,NMXHEP)
16809 C  extension to standard particle data interface (PHOJET specific)
16810       INTEGER IMPART,IPHIST,ICOLOR
16811       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16812 C  color string configurations including collapsed strings and hadrons
16813       INTEGER MSTR
16814       PARAMETER (MSTR=500)
16815       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16816       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16817      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16818      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16819
16820       INTEGER IREJ
16821
16822       DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16823       INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16824      &        IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16825
16826       integer indx(500),indx_max
16827
16828       DOUBLE PRECISION DT_RNDM
16829       INTEGER ipho_pdg2id
16830       EXTERNAL DT_RNDM,ipho_pdg2id
16831
16832       DOUBLE PRECISION PYP,RQLUN
16833       INTEGER PYK
16834
16835       INTEGER MSTU,MSTJ
16836       DOUBLE PRECISION PARU,PARJ
16837       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16838       INTEGER N,NPAD,K
16839       DOUBLE PRECISION P,V
16840       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16841
16842       DIMENSION IJOIN(100)
16843
16844       IREJ = 0
16845       IF(ABS(ISWMDL(6)).GT.3) THEN
16846         WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16847      &    'invalid value of ISWMDL(6)',ISWMDL(6)
16848         CALL PHO_ABORT
16849       ENDIF
16850
16851 C  popcorn suppression
16852         IF(PARMDL(134).GT.0.D0) THEN
16853           IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16854             MSTJ(12) = 2
16855           ELSE
16856             MSTJ(12) = 1
16857           ENDIF
16858         ENDIF
16859
16860 C  copy partons to fragmentation code JETSET
16861         IP = 0
16862         IP_old = 1
16863
16864         DO 300 J=1,ISTR
16865
16866 C  select partons with common production process
16867           IGEN = NPOS(4,J)
16868           if(IGEN.lt.0) goto 299
16869
16870           indx_max = 0
16871           DO 400 I=J,ISTR
16872             if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
16873
16874 C  write final particles/resonances to JETSET
16875               IF(NCODE(I).EQ.-99) THEN
16876                 II = NPOS(1,I)
16877                 IP = IP+1
16878                 P(IP,1) = PHEP(1,II)
16879                 P(IP,2) = PHEP(2,II)
16880                 P(IP,3) = PHEP(3,II)
16881                 P(IP,4) = PHEP(4,II)
16882                 P(IP,5) = PHEP(5,II)
16883                 K(IP,1) = 1
16884                 K(IP,2) = IDHEP(II)
16885                 K(IP,3) = 0
16886                 K(IP,4) = 0
16887                 K(IP,5) = 0
16888                 IPHIST(2,II) = IP
16889                 if(indx_max.eq.500) then
16890                   WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
16891      &              'no space left in index vector (indx,Kevent)',
16892      &              indx_max,KEVENT
16893                   IREJ = 1
16894                   return
16895                 endif
16896                 indx_max = indx_max+1
16897                 indx(indx_max) = II
16898 C  write partons to JETSET
16899               ELSE IF(NCODE(I).GE.0) THEN
16900                 K1 = JMOHEP(1,NPOS(1,I))
16901                 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
16902                 IJ = 0
16903                 DO II=K1,K2
16904                   IP = IP+1
16905                   P(IP,1) = PHEP(1,II)
16906                   P(IP,2) = PHEP(2,II)
16907                   P(IP,3) = PHEP(3,II)
16908                   P(IP,4) = PHEP(4,II)
16909                   P(IP,5) = PHEP(5,II)
16910                   K(IP,1) = 1
16911                   K(IP,2) = IDHEP(II)
16912                   K(IP,3) = 0
16913                   K(IP,4) = 0
16914                   K(IP,5) = 0
16915                   IPHIST(2,II) = IP
16916                   IJ = IJ+1
16917                   IJOIN(IJ) = IP
16918                   indx_max = indx_max+1
16919                   indx(indx_max) = II
16920                 ENDDO
16921                 II = JMOHEP(2,NPOS(1,I))
16922                 IF((II.GT.0).AND.(II.NE.K1)) THEN
16923                   IP = IP+1
16924                   P(IP,1) = PHEP(1,II)
16925                   P(IP,2) = PHEP(2,II)
16926                   P(IP,3) = PHEP(3,II)
16927                   P(IP,4) = PHEP(4,II)
16928                   P(IP,5) = PHEP(5,II)
16929                   K(IP,1) = 1
16930                   K(IP,2) = IDHEP(II)
16931                   K(IP,3) = 0
16932                   K(IP,4) = 0
16933                   K(IP,5) = 0
16934                   IPHIST(2,II) = IP
16935                   IJ = IJ+1
16936                   IJOIN(IJ) = IP
16937                   indx_max = indx_max+1
16938                   indx(indx_max) = II
16939                 ENDIF
16940                 N = IP
16941 C  connect partons to strings
16942                 CALL PYJOIN(IJ,IJOIN)
16943               ENDIF
16944
16945               NPOS(4,I) = -NPOS(4,I)
16946             endif
16947  400      continue
16948
16949 C  set Lund counter
16950           N = IP
16951           if(IP.eq.0) goto 299
16952
16953 C  hard final state evolution
16954           IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
16955             ISH = 0
16956             do 125 k1=1,indx_max
16957               I = indx(k1)
16958               IF(IPHIST(1,I).LE.-100) THEN
16959                 ISH = ISH+1
16960                 IJOIN(ISH) = I
16961               ENDIF
16962  125        continue
16963             IF(ISH.GE.2) THEN
16964               DO 130 K1=1,ISH
16965                 IF(IJOIN(K1).EQ.0) GOTO 130
16966                 I = IJOIN(K1)
16967                 IF((IPAMDL(102).EQ.1)
16968      &             .AND.(IPHIST(1,I).NE.-100)) GOTO 130
16969                 DO 135 K2=K1+1,ISH
16970                   IF(IJOIN(K2).EQ.0) GOTO 135
16971                   II = IJOIN(K2)
16972                   IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
16973                     PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
16974                     PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
16975                     RQLUN = MIN(PT1,PT2)
16976                     IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
16977      &                'PHO_STRFRA: PYSHOW called',I,II,RQLUN
16978                     CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
16979                     IJOIN(K1) = 0
16980                     IJOIN(K2) = 0
16981                     GOTO 130
16982                   ENDIF
16983  135            CONTINUE
16984  130          CONTINUE
16985             ENDIF
16986           ENDIF
16987
16988 C  fragment parton / hadron configuration (hadronization & decay)
16989
16990           IF(ISWMDL(6).NE.0) THEN
16991             II = MSTU(21)
16992             MSTU(21) = 1
16993             CALL PYEXEC
16994             MSTU(21) = II
16995 C  Lund warning?
16996             if(MSTU(28).ne.0) then
16997               IF(IDEB(22).GE.10) THEN
16998                 WRITE(LO,'(1X,A,I12,I3)')
16999      &            'PHO_STRFRA:(1) Lund code warning (EV/code)',
17000      &            KEVENT,MSTU(28)
17001                 CALL PHO_PREVNT(2)
17002               ENDIF
17003             endif
17004 C  event accepted?
17005             IF(MSTU(24).NE.0) THEN
17006               IF(IDEB(22).GE.2) THEN
17007                 WRITE(LO,'(1X,A,I12,I3)')
17008      &            'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
17009      &            KEVENT,MSTU(24)
17010                 CALL PHO_PREVNT(2)
17011               ENDIF
17012               IREJ = 1
17013               RETURN
17014             ENDIF
17015           ENDIF
17016
17017           IP = N
17018 C  change particle status in JETSET to avoid internal adjustments
17019           do k1=IP_old,IP
17020             K(k1,1) = K(k1,1)+1000
17021           enddo
17022           IP_old = IP+1
17023
17024  299      continue
17025  300    CONTINUE
17026
17027 C  restore original JETSET particle status codes
17028         do i=1,N
17029           K(i,1) = K(i,1)-1000
17030         enddo
17031
17032 *       IF(IDEB(22).GE.25) THEN
17033 *         WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17034 *    &      'particle/string system before fragmentation'
17035 *         CALL PHO_PREVNT(2)
17036 *       ENDIF
17037
17038 C  copy hadrons back to POEVT1 / POEVT2
17039
17040         IF(IP.GT.0) THEN
17041           NHEP1 = NHEP+1
17042           NLINES = PYK(0,1)
17043 C  copy hadrons back with full history information
17044           IF(IPAMDL(178).EQ.1) THEN
17045             DO 155 II=1,ISTR
17046               IF(NCODE(II).GE.0) THEN
17047                 K1 = IPHIST(2,NPOS(2,II))
17048                 K2 = IPHIST(2,-NPOS(3,II))
17049               ELSE IF(NCODE(II).EQ.-99) THEN
17050                 K1 = IPHIST(2,NPOS(1,II))
17051                 K2 = K1
17052               ELSE
17053                 GOTO 149
17054               ENDIF
17055               IFOUND = 0
17056               DO 160 J=1,NLINES
17057                 IF(PYK(J,7).EQ.1) THEN
17058                   IPMOTH = PYK(J,15)
17059                   IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17060                     IBAM = ipho_pdg2id(PYK(J,8))
17061                     IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17062                       IF(IDEB(22).GE.2) THEN
17063                         WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17064      &                    'LUND interface (1) rejection'
17065                         CALL PHO_PREVNT(2)
17066                       ENDIF
17067                       IREJ = 1
17068                       RETURN
17069                     ENDIF
17070                     IFOUND = IFOUND+1
17071                     PX = PYP(J,1)
17072                     PY = PYP(J,2)
17073                     PZ = PYP(J,3)
17074                     HE = PYP(J,4)
17075                     XMB = PYP(J,5)**2
17076 C  register parton/hadron
17077                     IS = 1
17078                     IF(IBAM.EQ.0) THEN
17079                       IF(ISWMDL(6).EQ.0) THEN
17080                         IS = -1
17081                       ELSE
17082                         IF(IDEB(22).GE.2) THEN
17083                           WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17084      &                      'LUND interface (2) rejection'
17085                           CALL PHO_PREVNT(2)
17086                         ENDIF
17087                         IREJ = 1
17088                         RETURN
17089                       ENDIF
17090                     ENDIF
17091                     CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17092      &                PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17093                     ISTHEP(IPOS) = 1
17094                   ENDIF
17095                 ENDIF
17096  160          CONTINUE
17097               IF(IFOUND.EQ.0) THEN
17098                 IF(IDEB(2).GE.2) THEN
17099                   WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17100      &            'no particles found for string (EVE,ISTR):',KEVENT,II
17101                 ENDIF
17102                 ISTHEP(NPOS(1,II)) = 2
17103               ENDIF
17104  149          CONTINUE
17105  155        CONTINUE
17106           ELSE
17107 C  copy hadrons back without history information
17108             JDAHEP(1,1) = NHEP1
17109             JDAHEP(1,2) = NHEP1
17110             DO 170 J=1,NLINES
17111               IF(PYK(J,7).EQ.1) THEN
17112                 IBAM = ipho_pdg2id(PYK(J,8))
17113                 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17114                   IF(IDEB(22).GE.2) THEN
17115                     WRITE(LO,'(/1X,A)')
17116      &                'PHO_STRFRA: LUND interface (3) rejection'
17117                     CALL PHO_PREVNT(2)
17118                   ENDIF
17119                   IREJ = 1
17120                   RETURN
17121                 ENDIF
17122                 PX = PYP(J,1)
17123                 PY = PYP(J,2)
17124                 PZ = PYP(J,3)
17125                 HE = PYP(J,4)
17126                 XMB = PYP(J,5)**2
17127 C  register parton/hadron
17128                 IS = 1
17129                 IF(IBAM.EQ.0) THEN
17130                   IF(ISWMDL(6).EQ.0) THEN
17131                     IS = -1
17132                   ELSE
17133                     IF(IDEB(22).GE.2) THEN
17134                       WRITE(LO,'(/1X,A)')
17135      &                  'PHO_STRFRA: LUND interface (4) rejection'
17136                       CALL PHO_PREVNT(2)
17137                     ENDIF
17138                     IREJ = 1
17139                     RETURN
17140                   ENDIF
17141                 ENDIF
17142                 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17143      &            HE,J,0,0,0,IPOS,1)
17144                 ISTHEP(IPOS) = 1
17145               ENDIF
17146  170        CONTINUE
17147             DO 180 II=1,ISTR
17148               IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17149      &          ISTHEP(NPOS(1,II)) = 2
17150  180        CONTINUE
17151           ENDIF
17152         ENDIF
17153
17154 C  debug event status
17155       IF(IDEB(22).GE.15) THEN
17156         WRITE(LO,'(//1X,A)')
17157      &    'PHO_STRFRA: particle system after fragmentation'
17158         CALL PHO_PREVNT(2)
17159       ENDIF
17160
17161       END
17162
17163 *$ CREATE PHO_EVEINI.FOR
17164 *COPY PHO_EVEINI
17165 CDECK  ID>, PHO_EVEINI
17166       SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17167 C********************************************************************
17168 C
17169 C     prepare /POEVT1/ for new event
17170 C
17171 C     first subroutine called for each event
17172 C
17173 C     input:   P1(4)  particle 1
17174 C              P2(4)  particle 2
17175 C              IMODE  0    general initialization
17176 C                     1    initialization of particles and kinematics
17177 C                     2    initialization after internal rejection
17178 C
17179 C     output:  IP1,IP2  index of interacting particles
17180 C
17181 C********************************************************************
17182       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17183       SAVE
17184
17185       DIMENSION P1(4),P2(4)
17186
17187       PARAMETER ( EPS    =  1.D-5,
17188      &            DEPS   =  1.D-15 )
17189
17190 C  input/output channels
17191       INTEGER LI,LO
17192       COMMON /POINOU/ LI,LO
17193 C  event debugging information
17194       INTEGER NMAXD
17195       PARAMETER (NMAXD=100)
17196       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17197      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17198       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17199      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17200 C  model switches and parameters
17201       CHARACTER*8 MDLNA
17202       INTEGER ISWMDL,IPAMDL
17203       DOUBLE PRECISION PARMDL
17204       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17205 C  general process information
17206       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17207       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17208 C  gamma-lepton or gamma-hadron vertex information
17209       INTEGER IGHEL,IDPSRC,IDBSRC
17210       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17211      &                 RADSRC,AMSRC,GAMSRC
17212       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17213      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17214      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17215 C  global event kinematics and particle IDs
17216       INTEGER IFPAP,IFPAB
17217       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17218       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17219 C  energy-interpolation table
17220       INTEGER IEETA2
17221       PARAMETER ( IEETA2 = 20 )
17222       INTEGER ISIMAX
17223       DOUBLE PRECISION SIGTAB,SIGECM
17224       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17225 C  cross sections
17226       INTEGER IPFIL,IFAFIL,IFBFIL
17227       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17228      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17229      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17230      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17231      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17232       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17233      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17234      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17235      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17236      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17237      &                IPFIL,IFAFIL,IFBFIL
17238 C  color string configurations including collapsed strings and hadrons
17239       INTEGER MSTR
17240       PARAMETER (MSTR=500)
17241       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17242       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17243      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17244      &                NNCH(MSTR),IBHAD(MSTR),ISTR
17245 C  standard particle data interface
17246       INTEGER NMXHEP
17247       PARAMETER (NMXHEP=4000)
17248       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17249       DOUBLE PRECISION PHEP,VHEP
17250       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17251      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17252      &                VHEP(4,NMXHEP)
17253 C  extension to standard particle data interface (PHOJET specific)
17254       INTEGER IMPART,IPHIST,ICOLOR
17255       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17256 C  table of particle indices for recursive PHOJET calls
17257       INTEGER MAXIPX
17258       PARAMETER ( MAXIPX = 100 )
17259       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17260       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17261      &                IPOIX1,IPOIX2,IPOIX3
17262 C  event weights and generated cross section
17263       INTEGER IPOWGC,ISWCUT,IVWGHT
17264       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17265       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17266      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17267
17268       DIMENSION IM(2)
17269
17270 C  reset debug variables
17271       KSPOM  = 0
17272       KHPOM  = 0
17273       KSREG  = 0
17274       KHDIR  = 0
17275       KSTRG  = 0
17276       KHTRG  = 0
17277       KSLOO  = 0
17278       KHLOO  = 0
17279       KSDPO  = 0
17280       KSOFT  = 0
17281       KHARD  = 0
17282 C
17283       IDNODF = 0
17284       IDIFR1 = 0
17285       IDIFR2 = 0
17286       IDDPOM = 0
17287       ISTR   = 0
17288       IPOIX1 = 0
17289       IF(ISWMDL(14).GT.0) IPOIX1 = 1
17290       IPOIX2 = 0
17291       IPOIX3 = 0
17292 C  reset /POEVT1/ and /POEVT2/
17293       CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17294      &            0,0,0,0,IPOS,0)
17295       CALL PHO_SELCOL(0,0,0,0,0,0,0)
17296       DO 15 I=0,10
17297         IPOWGC(I) = 0
17298  15   CONTINUE
17299
17300 C  initialization of particle kinematics
17301
17302 C  lepton-photon/hadron-photon vertex and initial particles
17303         IM(1) = 0
17304         IM(2) = 0
17305         IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17306           CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17307      &      PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17308         ELSE
17309           CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17310      &      P1(4),0,0,0,0,IP1,1)
17311         ENDIF
17312         IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17313           CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17314      &      PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17315         ELSE
17316           CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17317      &      P2(4),0,0,0,0,IP2,1)
17318         ENDIF
17319         IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17320           CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17321      &      PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17322           CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17323      &      P1(4),0,0,0,0,IP1,1)
17324         ENDIF
17325         IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17326           CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17327      &      PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17328           CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17329      &      P2(4),0,0,0,0,IP2,1)
17330         ENDIF
17331         NEVHEP = KACCEP
17332
17333       IF(IMODE.LE.1) THEN
17334 C  CMS energy
17335         ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17336      &           -(P1(3)+P2(3))**2)
17337 *       CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17338         PMASS(1) = PHEP(5,IP1)
17339         PVIRT(1) = 0.D0
17340         IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17341         PMASS(2) = PHEP(5,IP2)
17342         PVIRT(2) = 0.D0
17343         IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17344       ENDIF
17345
17346 C  cross section calculations
17347
17348       IF(IMODE.NE.1) THEN
17349         IP = 1
17350         CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17351      &              ECM,PVIRT(1),PVIRT(2))
17352       ENDIF
17353
17354       IF(IMODE.LE.0) THEN
17355 C  effective cross section
17356         SIGGEN(3) = 0.D0
17357         IF(ISWMDL(2).ge.1) THEN
17358           IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17359      &      -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17360      &      -SIGHDD-SIGDIR
17361           IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17362           IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17363           IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17364           IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17365           IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17366           IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17367           IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17368 C  simulate only hard scatterings
17369         ELSE
17370           IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17371           IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17372         ENDIF
17373
17374       ENDIF
17375
17376 C  reset of mother/daughter relations only (IMODE = 2)
17377
17378 C  debug output
17379       IF(IDEB(63).GE.15) THEN
17380         WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17381      &    '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17382         IF(IMODE.LE.0) THEN
17383           WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17384      &      'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17385      &      FSUP,FSUH,FSUD
17386           ONEM = -1.D0
17387           ITMP = IDEB(57)
17388           IDEB(57) = MAX(5,ITMP)
17389           CALL PHO_XSECT(1,0,ONEM)
17390           IDEB(57) = ITMP
17391         ENDIF
17392         CALL PHO_PREVNT(0)
17393       ENDIF
17394
17395       END
17396
17397 *$ CREATE PHO_CSINT.FOR
17398 *COPY PHO_CSINT
17399 CDECK  ID>, PHO_CSINT
17400       SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17401 C********************************************************************
17402 C
17403 C     calculate cross sections by interpolation
17404 C
17405 C     input:   IP          particle combination
17406 C              IFPA/B      particle PDG number
17407 C              IHLA/B      particle helicity (photons only)
17408 C              ECM         c.m. energy (GeV)
17409 C              PVIR2A      virtuality of particle A (GeV**2, positive)
17410 C              PVIR2B      virtuality of particle B (GeV**2, positive)
17411 C
17412 C     output:  cross sections stored in /POCSEC/
17413 C
17414 C********************************************************************
17415       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17416       SAVE
17417
17418       PARAMETER ( EPS    =  1.D-5,
17419      &            DEPS   =  1.D-15 )
17420
17421 C  input/output channels
17422       INTEGER LI,LO
17423       COMMON /POINOU/ LI,LO
17424 C  some constants
17425       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17426       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17427      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17428 C  event debugging information
17429       INTEGER NMAXD
17430       PARAMETER (NMAXD=100)
17431       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17432      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17433       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17434      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17435 C  model switches and parameters
17436       CHARACTER*8 MDLNA
17437       INTEGER ISWMDL,IPAMDL
17438       DOUBLE PRECISION PARMDL
17439       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17440 C  energy-interpolation table
17441       INTEGER IEETA2
17442       PARAMETER ( IEETA2 = 20 )
17443       INTEGER ISIMAX
17444       DOUBLE PRECISION SIGTAB,SIGECM
17445       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17446 C  cross sections
17447       INTEGER IPFIL,IFAFIL,IFBFIL
17448       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17449      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17450      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17451      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17452      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17453       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17454      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17455      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17456      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17457      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17458      &                IPFIL,IFAFIL,IFBFIL
17459 C  hard cross sections and MC selection weights
17460       INTEGER Max_pro_2
17461       PARAMETER ( Max_pro_2 = 16 )
17462       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17463      &  MH_acc_1,MH_acc_2
17464       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17465       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17466      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17467      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17468      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17469      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17470
17471       DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17472
17473       dimension PD(-6:6),FH_T(2),FH_L(2)
17474
17475 C  debug
17476       IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17477      &  'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17478      &  IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17479
17480 C  check currently stored cross sections
17481       IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17482      &   .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17483      &   .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17484 C  nothing to calculate
17485         IF(IDEB(15).GE.20)
17486      &    WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17487         RETURN
17488       ELSE
17489
17490 C  copy to local fields
17491         IFPAP(1) = IFPA
17492         IFPAP(2) = IFPB
17493         IHEL(1)  = IHLA
17494         IHEL(2)  = IHLB
17495         PVIRT(1) = PVIR2A
17496         PVIRT(2) = PVIR2B
17497
17498 C  load cross sections from interpolation table
17499         IF(ECM.LE.SIGECM(IP,1)) THEN
17500           I1 = 1
17501           I2 = 2
17502         ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17503           DO 50 I=2,ISIMAX
17504             IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17505  50       CONTINUE
17506  200      CONTINUE
17507           I1 = I-1
17508           I2 = I
17509         ELSE
17510           WRITE(LO,'(/1X,A,2E12.3)')
17511      &      'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17512           CALL PHO_PREVNT(-1)
17513           I1 = ISIMAX-1
17514           I2 = ISIMAX
17515         ENDIF
17516         FAC2=0.D0
17517         IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17518      &                    /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17519         FAC1=1.D0-FAC2
17520
17521 C  cross section dependence on photon virtualities
17522         DO 140 K=1,2
17523           FSUP(K) = 1.D0
17524           FSUD(K) = 1.D0
17525           FSUH(K) = 1.D0
17526           IF(IFPAP(K).EQ.22) THEN
17527             IF(ISWMDL(10).GE.1) THEN
17528               FSUP(K) = 0.D0
17529               FSUT(K) = 0.D0
17530               FSUL(K) = 0.D0
17531               FSUH(K) = 0.D0
17532 C  GVDM factors for transverse/longitudinal photons
17533               DO 150 I=1,3
17534                 FSUT(K) = FSUT(K)+PARMDL(26+I)
17535      &                   /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17536                 FSUL(K) = FSUL(K)
17537      &                   +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17538      &                   /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17539  150          CONTINUE
17540               FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17541 C  transverse part
17542               IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17543                 FSUP(K) = FSUT(K)
17544                 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17545 C  diffraction of trans. photons corresponds mainly to leading twist
17546                 FSUD(K) = 1.D0
17547               ENDIF
17548 C  longitudinal (scalar) part
17549               IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17550                 FSUP(K) = FSUP(K)+FSUL(K)
17551                 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17552 C  diffraction of long. photons corresponds mainly to higher twist
17553                 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17554      &                   /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17555      &                   /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17556               ENDIF
17557 C  debug output
17558               if(ideb(15).ge.10) then
17559                 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17560      &            'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17561      &            K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17562               endif
17563             ENDIF
17564           ENDIF
17565  140    CONTINUE
17566
17567         FACP = FSUP(1)*FSUP(2)
17568         FACH = FSUH(1)*FSUH(2)
17569         FACD = FSUD(1)*FSUD(2)
17570
17571 C  matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17572
17573         if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17574      &     .and.(IPAMDL(117).gt.0)) then
17575 C  check kinematic limit
17576           Q2_max = max(PVIRT(1),PVIRT(2))
17577           Q2_min = min(PVIRT(1),PVIRT(2))
17578           if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17579
17580 C  calculate F2 from current parton density
17581             if(PVIRT(1).gt.PVIRT(2)) then
17582               K = 2
17583             else
17584               K = 1
17585             endif
17586             Q2 = Q2_max
17587             P2 = Q2_min
17588             X = Q2/(ECM**2+Q2+P2)
17589             call pho_actpdf(IFPAP(K),K)
17590             call pho_pdf(K,X,Q2,P2,PD)
17591 C  light quark contribution
17592             F2_light = 0.D0
17593             do j=1,3
17594               F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17595             enddo
17596 C  heavy quark contribution
17597             call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17598             F2_c = 2.D0*4.D0/9.D0*xpdf_c
17599             F2 = (F2_light+F2_c)
17600
17601 C  calculate model prediction
17602             SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17603             SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17604             CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17605
17606             if(ISWMDL(10).ge.2) then
17607
17608 C  calculate all helicity combinations
17609               if(IPAMDL(115).eq.0) then
17610                 SIGDIH    = HSig(14)
17611                 SIGSRH(1) = HSig(10)+HSig(11)
17612                 SIGSRH(2) = HSig(12)+HSig(13)
17613                 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17614 C  photon helicity factors
17615                 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17616                 FH_L(1) = 1.D0-FH_T(1)
17617                 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17618                 FH_L(2) = 1.D0-FH_T(2)
17619                 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17620      &                  + SIGDIH*FH_T(1)*FH_T(2)
17621      &                  + SIGSRH(1)*FH_T(1)*FSUT(2)
17622      &                  + SIGSRH(2)*FSUT(1)*FH_T(2)
17623                 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17624      &                  + SIGDIH*FH_T(1)*FH_L(2)
17625      &                  + SIGSRH(1)*FH_T(1)*FSUL(2)
17626      &                  + SIGSRH(2)*FSUT(1)*FH_L(2)
17627                 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17628      &                  + SIGDIH*FH_L(1)*FH_T(2)
17629      &                  + SIGSRH(1)*FH_L(1)*FSUT(2)
17630      &                  + SIGSRH(2)*FSUL(1)*FH_T(2)
17631                 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17632      &                  + SIGDIH*FH_L(1)*FH_L(2)
17633      &                  + SIGSRH(1)*FH_L(1)*FSUL(2)
17634      &                  + SIGSRH(2)*FSUL(1)*FH_L(2)
17635               else
17636 C  use explicit PDF virtuality dependence (pre-tabulated)
17637                 SIGDIH    = HSig(14)
17638                 SIGSRH(1) = HSig(10)+HSig(11)
17639                 SIGSRH(2) = HSig(12)+HSig(13)
17640                 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17641                 WRITE(LO,*) ' PHO_CSINT: invalid option for F2 matching'
17642                 stop
17643 *               CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17644 *    &                          Max_pro_2,3,4,1)
17645 *               SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17646 *    &                  + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17647 *               SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17648 *    &                  + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17649 *               SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17650 *    &                  + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17651 *               SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17652 *    &                  + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17653               endif
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               if(K.eq.2) then
17658                 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17659                 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17660      &               -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17661               else
17662                 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17663                 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17664      &               -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17665               endif
17666
17667             else
17668
17669 C  assume sig_eff = sigtot
17670               SIGDIH    = HSig(14)
17671               SIGSRH(1) = HSig(10)+HSig(11)
17672               SIGSRH(2) = HSig(12)+HSig(13)
17673               SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17674               SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17675      &                +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17676               Xnu = Ecm*Ecm+Q2+P2
17677               F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17678      &             *137.D0/GeV2mb
17679               F2m = F2_fac*SIGeff
17680               F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17681             endif
17682 *           WRITE(LO,*) ' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17683 *           WRITE(LO,*) ' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
17684
17685 C  global factor to re-scale suppression of soft contributions
17686             Fcorr = (F2-F2m+F2s)/F2s
17687 *           WRITE(LO,*) ' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
17688             FACP = FACP*Fcorr
17689
17690           endif
17691         endif
17692
17693         SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17694         SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17695         SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17696         J = 2
17697         DO 5 I=0,4
17698           DO 6 K=0,4
17699             J = J+1
17700             SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17701      &                  *FACP**2
17702  6        CONTINUE
17703  5      CONTINUE
17704
17705         SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17706         SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17707 C  suppression of multi-pomeron graphs (diffraction)
17708         SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17709      &             *FACP*FSUP(2)*FSUD(1)
17710         SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17711      &             *FACP*FSUP(1)*FSUD(2)
17712         SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17713      &             *FACP*FSUP(2)*FSUD(1)
17714         SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17715      &             *FACP*FSUP(1)*FSUD(2)
17716         SIGLDD    = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17717      &             *FACP**2*FACD
17718         SIGHDD    = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17719         SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17720      &             *FACP**2
17721         SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17722      &             *FACP*FSUP(2)*FSUD(1)
17723         SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17724      &             *FACP*FSUP(2)*FSUD(1)
17725         SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17726      &             *FACP*FSUP(1)*FSUD(2)
17727         SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17728      &             *FACP*FSUP(1)*FSUD(2)
17729         SIGLOO    = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17730         SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17731      &             *FACP**2
17732         SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17733      &             *FACP**2
17734         SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17735      &             *FACP**2
17736         SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17737      &             *FACP**2
17738
17739 C  corrections due to photon virtuality dependence of PDFs
17740         if(iswmdl(2).eq.1) then
17741           CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17742 C  minimum bias event generation
17743           IF(IPAMDL(115).GE.1) THEN
17744 C  all the virtuality dependence is given by PDF parametrization
17745             SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17746             IF(IPAMDL(116).GE.2) THEN
17747 C  direct interaction according to full QPM calculation
17748               SIGDIH = HSig(14)
17749               SIGSRH(1) = HSig(10)+HSig(11)
17750               SIGSRH(2) = HSig(12)+HSig(13)
17751             ELSE
17752 C  direct interaction suppressed according to helicity factor
17753               SIGDIH = HSig(14)*FACH
17754               SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17755               SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17756             ENDIF
17757             WRITE(LO,*) ' PHO_CSINT: option not supported yet'
17758             stop
17759           ELSE
17760 C  rescale relevant hard processes
17761             SIGDIH    = HSig(14)
17762             SIGSRH(1) = HSig(10)+HSig(11)
17763             SIGSRH(2) = HSig(12)+HSig(13)
17764             SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17765             SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17766      &              +SIGSRH(2)*FSUP(1)*FSUH(2)
17767             SIGINE = SIGtmp+SIGDIR
17768             SIGTOT = SIGINE+SIGELA
17769           ENDIF
17770         else
17771 C  only hard interactions
17772           CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17773           SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17774           SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17775           SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17776           SIGHAR = HSig(9)*FACH
17777         endif
17778
17779         SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17780         SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17781         SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17782         J = 39
17783         DO 9 I=1,4
17784           DO 10 K=1,4
17785             J = J+1
17786             SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17787  10       CONTINUE
17788  9      CONTINUE
17789         SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17790         SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17791
17792         IPFIL  = IP
17793         IFAFIL = IFPA
17794         IFBFIL = IFPB
17795         ECMFIL = ECM
17796         P2AFIL = PVIR2A
17797         P2BFIL = PVIR2B
17798
17799         IF(IDEB(15).GE.20)
17800      &    WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17801
17802       ENDIF
17803
17804       END
17805
17806 *$ CREATE PHO_PRIMKT.FOR
17807 *COPY PHO_PRIMKT
17808 CDECK  ID>, PHO_PRIMKT
17809       SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17810 C***********************************************************************
17811 C
17812 C    give primordial kt to partons entering hard scatterings and
17813 C    remants connected to hard parton-parton interactions by color flow
17814 C
17815 C    input:  IMODE   -2   output of statistics
17816 C                    -1   initialization
17817 C                     1   sampling of primordial kt
17818 C            IF           first entry in /POEVT1/ to check
17819 C            IL           last entry in /POEVT1/ to check
17820 C            PTCUT        current value of PTCUT to distinguish
17821 C                         between soft and hard
17822 C
17823 C    output: IREJ     0   success
17824 C                     1   failure
17825 C
17826 C***********************************************************************
17827       IMPLICIT NONE
17828       SAVE
17829
17830       DOUBLE PRECISION DEPS
17831       PARAMETER ( DEPS = 1.D-15 )
17832
17833       INTEGER IMODE,IF,IL,IREJ
17834       DOUBLE PRECISION PTCUT
17835
17836 C  input/output channels
17837       INTEGER LI,LO
17838       COMMON /POINOU/ LI,LO
17839 C  event debugging information
17840       INTEGER NMAXD
17841       PARAMETER (NMAXD=100)
17842       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17843      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17844       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17845      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17846 C  model switches and parameters
17847       CHARACTER*8 MDLNA
17848       INTEGER ISWMDL,IPAMDL
17849       DOUBLE PRECISION PARMDL
17850       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17851 C  some constants
17852       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17853       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17854      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17855 C  data of c.m. system of Pomeron / Reggeon exchange
17856       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
17857       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
17858      &                 SIDP,CODP,SIFP,COFP
17859       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
17860      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
17861      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
17862 C  hard scattering data
17863       INTEGER MSCAHD
17864       PARAMETER ( MSCAHD = 50 )
17865       INTEGER LSCAHD,LSC1HD,LSIDX,
17866      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
17867       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
17868       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
17869      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
17870      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
17871      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
17872      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
17873      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
17874      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
17875 C  standard particle data interface
17876       INTEGER NMXHEP
17877       PARAMETER (NMXHEP=4000)
17878       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17879       DOUBLE PRECISION PHEP,VHEP
17880       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17881      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17882      &                VHEP(4,NMXHEP)
17883 C  extension to standard particle data interface (PHOJET specific)
17884       INTEGER IMPART,IPHIST,ICOLOR
17885       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17886
17887       DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
17888       DIMENSION PTS(0:2,5),XP(5),
17889      &  XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
17890
17891       INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
17892
17893       PARAMETER (IRMAX=200)
17894       DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
17895
17896       DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
17897      &                 DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
17898       INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
17899
17900 C  debug output
17901       IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
17902      &  'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
17903      &  IMODE,IF,IL,PTCUT
17904
17905 C  give primordial kt to partons engaged in a hard scattering
17906
17907       IF(IMODE.EQ.1) THEN
17908
17909         ISTART = IF
17910
17911  100    CONTINUE
17912
17913         NHD = 0
17914         IBAL(1) = 0
17915         IBAL(2) = 0
17916         IROT = 0
17917         ICOM = 0
17918         DO 110 I=ISTART,IL
17919           IF(ISTHEP(I).EQ.25) THEN
17920 C  hard scattering number
17921             NHD = IPHIST(1,I+1)
17922             ICOM = I
17923             K = LSIDX(NHD/100)
17924 C  calculate momenta of incoming partons
17925             POLD(1,1) = XHD(K,1)*ECMP/2.D0
17926             POLD(2,1) = POLD(1,1)
17927             POLD(1,2) = -XHD(K,2)*ECMP/2.D0
17928             POLD(2,2) = -POLD(1,2)
17929             ISTART = I+3
17930             GOTO 150
17931           ENDIF
17932  110    CONTINUE
17933         RETURN
17934
17935  150    CONTINUE
17936
17937 C  search for partons involved in hard interaction
17938         INEXT = 0
17939         IROT = 0
17940         DO 500 I=ISTART,IL
17941           IF(ABS(ISTHEP(I)).EQ.1) THEN
17942 C  hard scatterd partons (including ISR)
17943             IF((IPHIST(1,I).EQ.-NHD)
17944      &         .OR.(IPHIST(1,I).EQ.NHD+1)
17945      &         .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
17946               IROT = IROT+1
17947               IF(IROT.GT.IRMAX) THEN
17948                 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
17949      &            'no memory left in IROTT, event rejected (max/IROT)',
17950      &            IRMAX,IROT
17951                 CALL PHO_PREVNT(0)
17952                 IREJ = 1
17953                 RETURN
17954               ENDIF
17955               IROTT(IROT) = I
17956 C  hard remnant
17957             ELSE IF(IPHIST(1,I).EQ.NHD) THEN
17958               IF(PHEP(3,I).GT.0.D0) THEN
17959                 J = 1
17960               ELSE
17961                 J = 2
17962               ENDIF
17963               IBAL(J) = IBAL(J)+1
17964               IBALT(IBAL(J),J) = I
17965               XP2(IBAL(J),J) = PHEP(3,I)/ECMP
17966               IF(ISWMDL(24).EQ.0) THEN
17967                 IV2(IBAL(J),J) = 0
17968                 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
17969               ELSE IF(ISWMDL(24).EQ.1) THEN
17970                 IV2(IBAL(J),J) = -1
17971               ELSE
17972                 IV2(IBAL(J),J) = 1
17973               ENDIF
17974             ENDIF
17975 C  possibly further hard scattering
17976           ELSE IF(ISTHEP(I).EQ.25) THEN
17977             INEXT = 1
17978             ISTART = I
17979             GOTO 550
17980           ENDIF
17981  500    CONTINUE
17982  550    CONTINUE
17983
17984 C debug output
17985         if(IDEB(10).ge.15) then
17986           WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
17987      &      'hard scattering number: ',NHD/100
17988           WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
17989      &      'number of entries to rotate: ',IROT
17990           DO I=1,IROT
17991             WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17992      &        'entries to rotate: ',I,IROTT(I)
17993           ENDDO
17994           WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17995      &      'number of entries to balance: ',IBAL
17996           DO J=1,2
17997             DO I=1,IBAL(J)
17998               WRITE(LO,'(1X,2A,I2,2I5)')
17999      &          'PHO_PRIMKT: entries to balance (side,no,line)',
18000      &          J,I,IBALT(I,J)
18001             ENDDO
18002           ENDDO
18003         endif
18004
18005 C  incoming partons (comment lines), skip direct interacting particles
18006         DO 120 K=1,2
18007           IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
18008             IF(PHEP(3,ICOM+K).GT.0.D0) THEN
18009               J = 1
18010             ELSE
18011               J = 2
18012             ENDIF
18013             IBAL(J) = IBAL(J)+1
18014             IBALT(IBAL(J),J) = -ICOM-K
18015             XP2(IBAL(J),J) = POLD(1,J)/ECMP
18016             IV2(IBAL(J),J) = -1
18017           ENDIF
18018  120    CONTINUE
18019
18020 C  check consistency
18021         IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18022           WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18023      &      'inconsistent hard scattering remnant for event: ',KEVENT
18024           WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18025      &      'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18026      &      IMODE,IF,IL,PTCUT
18027           WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18028           DO 390 I=1,IROT
18029             WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18030  390      CONTINUE
18031           DO 392 J=1,2
18032             DO 395 I=1,IBAL(J)
18033               WRITE(LO,'(1X,A,I2,2I5)')
18034      &          'entries to balance (side,no,line)',J,I,IBALT(I,J)
18035  395        CONTINUE
18036  392      CONTINUE
18037           IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18038         ENDIF
18039
18040 C  calculate primordial kt
18041
18042 C  something to do?
18043         IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18044
18045 C  add transverse momentum (overwrite /POEVT1/ entries)
18046         DO 200 J=1,2
18047           IF(IBAL(J).GT.1) THEN
18048 C  sample from truncated distribution
18049             K = IBAL(J)
18050             DO 180 I=1,K
18051               IV(I) = IV2(I,J)
18052               XP(I) = XP2(I,J)
18053  180        CONTINUE
18054  190        CONTINUE
18055               CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18056             IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18057 C  transform incoming partons of hard scattering
18058             DEL = ABS(POLD(1,J))+POLD(2,J)
18059             PT2 = PTS(0,K)**2
18060             DEL2 = DEL*DEL
18061             PNEW(1,J) = PTS(1,K)
18062             PNEW(2,J) = PTS(2,K)
18063             PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18064             PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18065 C  spectator partons
18066             ESUM = 0.D0
18067             DO 220 I=1,IBAL(J)-1
18068               K = IBALT(I,J)
18069               PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18070               PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18071               ESUM = ESUM+PHEP(4,K)
18072  220        CONTINUE
18073 C  long. momentum transfer
18074             PP(3) = PNEW(3,J) - POLD(1,J)
18075             PP(4) = PNEW(4,J) - POLD(2,J)
18076             DO 230 I=1,IBAL(J)-1
18077               K = IBALT(I,J)
18078               FAC = PHEP(4,K)/ESUM
18079               PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18080               PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18081  230        CONTINUE
18082
18083 C  debug output
18084             IF(IDEB(10).GE.15) THEN
18085               WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18086      &          'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18087               WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18088      &          'new incoming:',J,(PNEW(I,J),I=1,4)
18089             ENDIF
18090
18091           ELSE
18092             PNEW(1,J) = 0.D0
18093             PNEW(2,J) = 0.D0
18094             PNEW(3,J) = POLD(1,J)
18095             PNEW(4,J) = POLD(2,J)
18096           ENDIF
18097  200    CONTINUE
18098
18099 C  transformation of hard scattering final states (including ISR)
18100
18101 C  old parton c.m. energy
18102         SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18103         EI = SQRT(SI)
18104 C  new parton c.m. energy
18105         SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18106      &       -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18107         EF = SQRT(SF)
18108         FAC = EF/EI
18109 C  debug output
18110         IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18111      &    'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18112
18113 C  calculate Lorentz transformation
18114         GAZ = -(POLD(1,1)+POLD(1,2))/EI
18115         GAE = (POLD(2,1)+POLD(2,2))/EI
18116         DO 240 I=1,4
18117           GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18118  240    CONTINUE
18119         CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18120      &    PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18121         PTOT = MAX(DEPS,PTOT)
18122         COD= PP(3)/PTOT
18123         SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18124         COF= 1.D0
18125         SIF= 0.D0
18126         IF(PTOT*SID.GT.1.D-5) THEN
18127           COF=PP(1)/(SID*PTOT)
18128           SIF=PP(2)/(SID*PTOT)
18129           ANORF=SQRT(COF*COF+SIF*SIF)
18130           COF=COF/ANORF
18131           SIF=SIF/ANORF
18132         ENDIF
18133
18134 C  debug output
18135 C  check consistency initial/final configuration before rotation
18136         IF(IDEB(10).GE.25) THEN
18137           WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18138      &      0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18139           DO I=1,4
18140             PP(I) = 0.D0
18141           ENDDO
18142           DO I=1,IROT
18143             K = IROTT(I)
18144             DO J=1,4
18145               PP(J) = PP(J)+PHEP(J,K)
18146             ENDDO
18147           ENDDO
18148           WRITE(LO,'(1X,A,1P,4E11.3)')
18149      &      'PHO_PRIMKT: fin. momentum (1):',PP
18150         ENDIF
18151
18152 C  apply rotation/boost to scattered particles
18153         DO 400 I=1,IROT
18154           K = IROTT(I)
18155           DO 350 J=1,4
18156             PP(J) = FAC*PHEP(J,K)
18157  350      CONTINUE
18158           CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18159      &      PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18160           CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18161      &      COD,SID,COF,SIF,XX,YY,ZZ)
18162           EE = PHEP(4,K)
18163           CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18164      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18165  400    CONTINUE
18166
18167 C  debug output
18168 C  check consistency initial/final configuration after rotation
18169         IF(IDEB(10).GE.25) THEN
18170           DO I=1,4
18171             PP(I) = PNEW(I,1)+PNEW(I,2)
18172           ENDDO
18173           WRITE(LO,'(1X,A,1P,4E11.3)')
18174      &      'PHO_PRIMKT: ini. momentum (2):',PP
18175           DO I=1,4
18176             PP(I) = 0.D0
18177           ENDDO
18178           DO I=1,IROT
18179             K = IROTT(I)
18180             DO J=1,4
18181               PP(J) = PP(J)+PHEP(J,K)
18182             ENDDO
18183           ENDDO
18184           WRITE(LO,'(1X,A,1P,4E11.3)')
18185      &      'PHO_PRIMKT: fin. momentum (2):',PP
18186         ENDIF
18187
18188         ENDIF
18189
18190         IF(INEXT.EQ.1) GOTO 100
18191
18192 C  initialization
18193
18194       ELSE IF(IMODE.EQ.-1) THEN
18195
18196 C  output of statistics etc.
18197
18198       ELSE IF(IMODE.EQ.-2) THEN
18199
18200 C  something wrong
18201
18202       ELSE
18203         WRITE(LO,'(/1X,A,I4)')
18204      &    'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18205         CALL PHO_ABORT
18206       ENDIF
18207
18208       END
18209
18210 *$ CREATE PHO_PARTPT.FOR
18211 *COPY PHO_PARTPT
18212 CDECK  ID>, PHO_PARTPT
18213       SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18214 C********************************************************************
18215 C
18216 C    assign to soft partons
18217 C
18218 C    input:  IMODE   -2   output of statistics
18219 C                    -1   initialization
18220 C                     0   sampling of pt for soft partons belonging to
18221 C                         soft Pomerons
18222 C                     1   sampling of pt for soft partons belonging to
18223 C                         hard Pomerons
18224 C            IF           first entry in /POEVT1/ to check
18225 C            IL           last entry in /POEVT1/ to check
18226 C            PTCUT        current value of PTCUT to distinguish
18227 C                         between soft and hard
18228 C
18229 C    output: IREJ     0   success
18230 C                     1   failure
18231 C
18232 C    (soft pt is sampled by call to PHO_SOFTPT)
18233 C
18234 C********************************************************************
18235       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18236       SAVE
18237
18238       PARAMETER ( DEPS = 1.D-15 )
18239
18240       INTEGER IMODE,IF,IL,IREJ
18241       DOUBLE PRECISION PTCUT
18242
18243 C  input/output channels
18244       INTEGER LI,LO
18245       COMMON /POINOU/ LI,LO
18246 C  event debugging information
18247       INTEGER NMAXD
18248       PARAMETER (NMAXD=100)
18249       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18250      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18251       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18252      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18253 C  model switches and parameters
18254       CHARACTER*8 MDLNA
18255       INTEGER ISWMDL,IPAMDL
18256       DOUBLE PRECISION PARMDL
18257       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18258 C  some constants
18259       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18260       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18261      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18262 C  data of c.m. system of Pomeron / Reggeon exchange
18263       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18264       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18265      &                 SIDP,CODP,SIFP,COFP
18266       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18267      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18268      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18269 C  standard particle data interface
18270       INTEGER NMXHEP
18271       PARAMETER (NMXHEP=4000)
18272       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18273       DOUBLE PRECISION PHEP,VHEP
18274       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18275      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18276      &                VHEP(4,NMXHEP)
18277 C  extension to standard particle data interface (PHOJET specific)
18278       INTEGER IMPART,IPHIST,ICOLOR
18279       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18280
18281       DOUBLE PRECISION PTS,PB,XP,XPB,PC
18282       DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18283
18284       INTEGER MODIFY,IV,IVB
18285       DIMENSION MODIFY(50),IV(50),IVB(2)
18286
18287 C  debug output
18288       IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18289      &  'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18290      &  IMODE,IF,IL,PTCUT
18291
18292       IF(IMODE.LT.0) GOTO 1000
18293
18294       IREJ = 0
18295       IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18296
18297 C  count entries to modify
18298       IENTRY = 0
18299       PTCUT2 = PTCUT**2
18300       EMIN = 1.D20
18301       IPEAK = 1
18302       ISTART = IF
18303
18304 C  soft Pomerons
18305
18306       IF(IMODE.EQ.0) THEN
18307         DO 300 I=ISTART,IL
18308           IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18309             IENTRY = IENTRY+1
18310             MODIFY(IENTRY) = I
18311             XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18312             IV(IENTRY) = 0
18313             IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18314             IF(PHEP(4,I).LT.EMIN) THEN
18315               EMIN = PHEP(4,I)
18316               IPEAK = IENTRY
18317             ENDIF
18318           ENDIF
18319  300    CONTINUE
18320
18321 C  hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18322
18323       ELSE IF(IMODE.EQ.1) THEN
18324
18325         DO 350 I=ISTART,IL
18326           IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18327             IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18328               IENTRY = IENTRY+1
18329               MODIFY(IENTRY) = I
18330               XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18331               IF(ISWMDL(24).EQ.0) THEN
18332                 IV(IENTRY) = 0
18333                 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18334               ELSE IF(ISWMDL(24).EQ.1) THEN
18335                 IV(IENTRY) = -1
18336               ELSE
18337                 IV(IENTRY) = 1
18338               ENDIF
18339               IF(PHEP(4,I).LT.EMIN) THEN
18340                 EMIN = PHEP(4,I)
18341                 IPEAK = IENTRY
18342               ENDIF
18343             ENDIF
18344           ENDIF
18345  350    CONTINUE
18346
18347 C  something wrong
18348
18349       ELSE
18350         WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18351         CALL PHO_ABORT
18352       ENDIF
18353
18354 C  debug output
18355       IF(IDEB(6).GE.5) THEN
18356         WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18357      &    'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18358         IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18359       ENDIF
18360
18361 C  nothing to do
18362       IF(IENTRY.LE.1) RETURN
18363
18364 C  sample pt of soft partons
18365
18366       IF(ISWMDL(5).LE.1) THEN
18367         ITER = 0
18368         IPEAK = DT_RNDM(DUM)*IENTRY+1
18369         CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18370         CALL PHO_SWAPD(XP(IPEAK),XP(1))
18371         CALL PHO_SWAPI(IV(IPEAK),IV(1))
18372  400    CONTINUE
18373 C  energy limited sampling
18374           PSUMX = 0.D0
18375           PSUMY = 0.D0
18376           ITER = ITER+1
18377           IF(ITER.GE.1000) THEN
18378             IF(IDEB(6).GE.3) THEN
18379               WRITE(LO,'(1X,A,3I5)')
18380      &          'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18381      &          IMODE,IENTRY,ITER
18382               WRITE(LO,'(8X,A,I5)') 'I  II  IV       XP         EP',
18383      &          IPEAK
18384               DO 405 I=1,IENTRY
18385                 II = MODIFY(I)
18386                 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18387      &            I,II,IV(I),XP(I),PHEP(4,II)
18388  405          CONTINUE
18389               IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18390             ENDIF
18391             IREJ = 1
18392             RETURN
18393           ENDIF
18394           DO 410 I=2,IENTRY
18395             II = MODIFY(I)
18396             PTMX = MIN(PHEP(4,II),PTCUT)
18397             XPB(1) = XP(I)
18398             IVB(1) = IV(I)
18399             IF(ISWMDL(5).EQ.0) THEN
18400               CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18401             ELSE
18402               CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18403             ENDIF
18404             PTS(0,I) = PB(0,1)
18405             PTS(1,I) = PB(1,1)
18406             PTS(2,I) = PB(2,1)
18407             PSUMX = PSUMX+PB(1,1)
18408             PSUMY = PSUMY+PB(2,1)
18409  410      CONTINUE
18410           PTREM = SQRT(PSUMX**2+PSUMY**2)
18411         IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18412         PTS(1,1) = -PSUMX
18413         PTS(2,1) = -PSUMY
18414       ELSE IF((ISWMDL(5).EQ.2)
18415      &        .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18416 C  unlimited sampling
18417         IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18418         CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18419         CALL PHO_SWAPD(XP(IPEAK),XP(1))
18420         CALL PHO_SWAPI(IV(IPEAK),IV(1))
18421         CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18422       ELSE IF(ISWMDL(5).EQ.3) THEN
18423 C  each string has balanced pt
18424         DO 500 K=1,IENTRY
18425           IF(IV(K).LE.-90) GOTO 499
18426           I1 = MODIFY(K)
18427           IC1 = -ICOLOR(1,I1)
18428           DO 510 L=K+1,IENTRY
18429             IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18430  510      CONTINUE
18431           WRITE(LO,'(//1X,A,I5)')
18432      &      'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18433           CALL PHO_ABORT
18434  511      CONTINUE
18435           I2 = MODIFY(L)
18436           AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18437      &           -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18438           AM   = SQRT(AMSQR)
18439           PTMX = AM/2.D0
18440           IVB(1) = MAX(IV(K),IV(L))
18441           XPB(1) = XP(K)
18442           CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18443           PTS(1,K) = PB(1,1)
18444           PTS(2,K) = PB(2,1)
18445           PTS(1,L) = -PB(1,1)
18446           PTS(2,L) = -PB(2,1)
18447           GAM    = (PHEP(4,I1)+PHEP(4,I2))/AM
18448           GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18449           PC(1) = PB(1,1)
18450           PC(2) = PB(2,1)
18451           PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18452           PC(3) = SIGN(PLONG,PHEP(3,I1))
18453           PC(4) = PTMX
18454           CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18455      &               PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18456           PC(1) = -PC(1)
18457           PC(2) = -PC(2)
18458           PC(3) = -PC(3)
18459           CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18460      &               PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18461           IV(K) = IV(K)-100
18462           IV(L) = IV(L)-100
18463  499      CONTINUE
18464  500    CONTINUE
18465       ELSE
18466         WRITE(LO,'(/1X,A,I4)')
18467      &    'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18468         CALL PHO_ABORT
18469       ENDIF
18470
18471 C  change partons in /POEVT1/
18472       DO 900 II=1,IENTRY
18473         IF(IV(II).GT.-90) THEN
18474           I = MODIFY(II)
18475           PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18476           PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18477           AMSQR = PHEP(4,I)**2
18478      &             -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18479           PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18480         ENDIF
18481  900  CONTINUE
18482
18483 C  debug output
18484       IF(IDEB(6).GE.15) THEN
18485         WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18486      &    'I  II  IV    XP    EP    PTS   PTX   PTY',IPEAK
18487         DO 505 I=1,IENTRY
18488           II = MODIFY(I)
18489           WRITE(LO,'(2X,3I5,1P,5E12.4)')
18490      &      I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18491  505    CONTINUE
18492         CALL PHO_PREVNT(0)
18493       ENDIF
18494       RETURN
18495
18496 C  initialization / output of statistics
18497  1000 CONTINUE
18498       CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18499
18500       END
18501
18502 *$ CREATE PHO_SOFTPT.FOR
18503 *COPY PHO_SOFTPT
18504 CDECK  ID>, PHO_SOFTPT
18505       SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18506 C***********************************************************************
18507 C
18508 C    select pt of soft string ends
18509 C
18510 C    input:    ISOFT          number of soft partons
18511 C                    -1       initialization
18512 C                    >=0      sampling of p_t
18513 C                    -2       output of statistics
18514 C              PTCUT          cutoff for soft strings
18515 C              PTMAX          maximal allowed PT
18516 C              XV             field of x values
18517 C              IV             0    sea quark
18518 C                             1    valence quark
18519 C
18520 C    output:   /POINT3/       containing parameters AAS,BETAS
18521 C              PTSOF          filed with soft pt values
18522 C
18523 C    note:     ISWMDL(3/4) = 0  dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18524 C              ISWMDL(3/4) = 1  dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18525 C              ISWMDL(3/4) = 2  photon wave function
18526 C              ISWMDL(3/4) = 10 no soft P_t assignment
18527 C
18528 C***********************************************************************
18529       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18530       SAVE
18531
18532       PARAMETER ( DEPS   =  1.D-15)
18533
18534       DIMENSION PTSOF(0:2,*),XV(*)
18535       DIMENSION IV(*)
18536
18537 C  input/output channels
18538       INTEGER LI,LO
18539       COMMON /POINOU/ LI,LO
18540 C  event debugging information
18541       INTEGER NMAXD
18542       PARAMETER (NMAXD=100)
18543       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18544      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18545       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18546      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18547 C  model switches and parameters
18548       CHARACTER*8 MDLNA
18549       INTEGER ISWMDL,IPAMDL
18550       DOUBLE PRECISION PARMDL
18551       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18552 C  data of c.m. system of Pomeron / Reggeon exchange
18553       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18554       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18555      &                 SIDP,CODP,SIFP,COFP
18556       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18557      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18558      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18559 C  data on most recent hard scattering
18560       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18561       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18562      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18563      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18564       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18565      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18566      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18567      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18568      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18569 C  data needed for soft-pt calculation
18570       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18571       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18572
18573       DIMENSION BETAB(100)
18574
18575 C  selection of pt
18576       IF(ISOFT.GE.0) THEN
18577         CALLS = CALLS + 1.D0
18578 C  sample according to model ISWMDL(3-6)
18579         IF(ISOFT.GT.1) THEN
18580  210      CONTINUE
18581           PTXS = 0.D0
18582           PTYS = 0.D0
18583           DO 300 I=2,ISOFT
18584             IMODE = ISWMDL(3)
18585 C  valence partons
18586             IF(IV(I).EQ.1) THEN
18587               BETA = BETAS(1)
18588 C  photon/pomeron valence part
18589               IF(IPAMDL(5).EQ.1) THEN
18590                 IF(XV(I).GE.0.D0) THEN
18591                   IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18592                     IMODE = ISWMDL(4)
18593                     BETA = BETAS(3)
18594                   ENDIF
18595                 ELSE
18596                   IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18597                     IMODE = ISWMDL(4)
18598                     BETA = BETAS(3)
18599                   ENDIF
18600                 ENDIF
18601               ELSE IF(IPAMDL(5).EQ.2) THEN
18602                 BETA = PARMDL(20)
18603               ELSE IF(IPAMDL(5).EQ.3) THEN
18604                 BETA = BETAS(3)
18605               ENDIF
18606 C  sea partons
18607             ELSE IF(IV(I).EQ.0) THEN
18608               BETA = BETAS(3)
18609 C  hard scattering remnant
18610             ELSE
18611               IF(IPAMDL(6).EQ.0) THEN
18612                 BETA = BETAS(1)
18613               ELSE IF(IPAMDL(6).EQ.1) THEN
18614                 BETA = BETAS(3)
18615               ELSE
18616                 BETA = PARMDL(20)
18617               ENDIF
18618             ENDIF
18619             BETA = MAX(BETA,0.01D0)
18620             CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18621             PTS = MIN(PTMAX,PTS)
18622             CALL PHO_SFECFE(SIG,COG)
18623             PTSOF(0,I) = PTS
18624             PTSOF(1,I) = COG*PTS
18625             PTSOF(2,I) = SIG*PTS
18626             PTXS = PTXS+PTSOF(1,I)
18627             PTYS = PTYS+PTSOF(2,I)
18628             BETAB(I) = BETA
18629  300      CONTINUE
18630 C  balancing of momenta
18631           PTS = SQRT(PTXS**2+PTYS**2)
18632           IF(PTS.GE.PTMAX) GOTO 210
18633           PTSOF(0,1) = PTS
18634           PTSOF(1,1) = -PTXS
18635           PTSOF(2,1) = -PTYS
18636           BETAB(1) = 0.D0
18637 C
18638 *400      CONTINUE
18639 C
18640 C  single parton only
18641         ELSE
18642           IMODE = ISWMDL(3)
18643 C  valence partons
18644           IF(IV(1).EQ.1) THEN
18645             BETA = BETAS(1)
18646 C  photon/Pomeron valence part
18647             IF(IPAMDL(5).EQ.1) THEN
18648               IF(XV(1).GE.0.D0) THEN
18649                 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18650                   IMODE = ISWMDL(4)
18651                   BETA = BETAS(3)
18652                 ENDIF
18653               ELSE
18654                 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18655                   IMODE = ISWMDL(4)
18656                   BETA = BETAS(3)
18657                 ENDIF
18658               ENDIF
18659             ELSE IF(IPAMDL(5).EQ.2) THEN
18660               BETA = PARMDL(20)
18661             ELSE IF(IPAMDL(5).EQ.3) THEN
18662               BETA = BETAS(3)
18663             ENDIF
18664 C  sea partons
18665           ELSE IF(IV(1).EQ.0) THEN
18666             BETA = BETAS(3)
18667 C  hard scattering remnant
18668           ELSE
18669             IF(IPAMDL(6).EQ.1) THEN
18670               BETA = BETAS(3)
18671             ELSE
18672               BETA = PARMDL(20)
18673             ENDIF
18674           ENDIF
18675           BETA = MAX(BETA,0.01D0)
18676           CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18677           PTS = MIN(PTMAX,PTS)
18678           CALL PHO_SFECFE(SIG,COG)
18679           PTSOF(0,1) = PTS
18680           PTSOF(1,1) = COG*PTS
18681           PTSOF(2,1) = SIG*PTS
18682           BETAB(1) = BETA
18683         ENDIF
18684 C  debug output
18685         IF(IDEB(29).GE.10) THEN
18686           WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18687           WRITE(LO,'(6X,A)') 'TABLE OF  I, IV, XV, PT, PT-X, PT-Y, BETA'
18688           DO 105 I=1,ISOFT
18689             WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18690      &        PTSOF(1,I),PTSOF(2,I),BETAB(I)
18691  105      CONTINUE
18692         ENDIF
18693
18694 C  initialization of statistics and parameters
18695
18696       ELSE IF(ISOFT.EQ.-1) THEN
18697         PTSMIN = 0.D0
18698         PTSMAX = PTCUT
18699         IMODE = -100+ISWMDL(3)
18700         CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18701
18702 C  output of statistics
18703
18704       ELSE IF(ISOFT.EQ.-2) THEN
18705       ELSE
18706         WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18707      &    'unsupported ISOFT ',ISOFT
18708         STOP
18709       ENDIF
18710       END
18711
18712 *$ CREATE PHO_SELPT.FOR
18713 *COPY PHO_SELPT
18714 CDECK  ID>, PHO_SELPT
18715       SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18716 C***********************************************************************
18717 C
18718 C    select pt from different distributions
18719 C
18720 C    input:    EE            energy (for initialization only)
18721 C                            otherwise x value of corresponding parton
18722 C              PTLOW         lower pt limit
18723 C              PTHIGH        upper pt limit
18724 C                            (PTHIGH > 20 will cause DEXP underflows)
18725 C
18726 C              IMODE = 0     dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18727 C              IMODE = 1     dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18728 C              IMODE = 2     dNs/dP_t according photon wave function
18729 C              IMODE = 10    no sampling
18730 C
18731 C              IMODE = -100+IMODE    initialization according to
18732 C                                    given limitations
18733 C
18734 C    output:   PTS           sampled pt value
18735 C    initialization:
18736 C              BETA          soft pt slope in central region
18737 C
18738 C***********************************************************************
18739       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18740       SAVE
18741
18742       PARAMETER ( PI2    =  6.28318530718D0,
18743      &            AMIN   =  1.D-2,
18744      &            EPS    =  1.D-7,
18745      &            DEPS   =  1.D-30)
18746
18747 C  input/output channels
18748       INTEGER LI,LO
18749       COMMON /POINOU/ LI,LO
18750 C  event debugging information
18751       INTEGER NMAXD
18752       PARAMETER (NMAXD=100)
18753       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18754      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18755       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18756      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18757 C  model switches and parameters
18758       CHARACTER*8 MDLNA
18759       INTEGER ISWMDL,IPAMDL
18760       DOUBLE PRECISION PARMDL
18761       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18762 C  data of c.m. system of Pomeron / Reggeon exchange
18763       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18764       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18765      &                 SIDP,CODP,SIFP,COFP
18766       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18767      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18768      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18769 C  average number of cut soft and hard ladders (obsolete)
18770       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18771       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18772 C  data needed for soft-pt calculation
18773       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18774       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18775
18776       DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18777       EXTERNAL PHO_CONN0,PHO_CONN1
18778
18779 C  initialization
18780
18781       IF(IMODE.LT.0) GOTO 100
18782
18783       PX = PTHIGH
18784       PTS = 0.D0
18785
18786 C  initial checks
18787
18788       IF(PX.LT.AMIN) RETURN
18789
18790       IF((PX-PTLOW).LT.0.01) THEN
18791         IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18792      &    'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18793         RETURN
18794       ENDIF
18795
18796 C  sampling of pt values according to IMODE
18797
18798       IF(IMODE.EQ.0) THEN
18799
18800         FAC1 = EXP(-BETA*PX**2)
18801         FAC2 = (1.D0-FAC1)
18802  25     CONTINUE
18803           XI1 = DT_RNDM(PX)*FAC2 + FAC1
18804           PTS = SQRT(-1.D0/BETA*LOG(XI1))
18805         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18806
18807       ELSE IF(IMODE.EQ.1) THEN
18808
18809         XIMIN = EXP(-BETA*PTHIGH)
18810         XIDEL = 1.D0-XIMIN
18811  50     CONTINUE
18812           PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18813      &              *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18814         IF(PTS.LT.XMT) GOTO 50
18815         PTS = SQRT(PTS**2-XMT2)
18816         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18817
18818       ELSE IF(IMODE.EQ.2) THEN
18819
18820         IF(EE.GE.0.D0) THEN
18821           P2 = PVIRTP(1)
18822         ELSE
18823           P2 = PVIRTP(2)
18824         ENDIF
18825         XV = ABS(EE)
18826         AA = (1.D0-XV)*XV*P2+PARMDL(25)
18827  75     CONTINUE
18828           PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
18829         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
18830
18831 C  something wrong
18832
18833       ELSE IF(IMODE.NE.10) THEN
18834         WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
18835         CALL PHO_ABORT
18836       ENDIF
18837
18838 C  debug output
18839       IF(IDEB(5).GE.20) THEN
18840         WRITE(LO,'(1X,A,I3,4E10.3)')
18841      &    'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
18842      &    IMODE,BETA,PTLOW,PTHIGH,PTS
18843       ENDIF
18844       RETURN
18845
18846 C  initialization
18847  100  CONTINUE
18848         PTSMIN = PTLOW
18849         PTSMAX = PTHIGH
18850         PTCON = PTHIGH
18851 C  calculation of parameters
18852         INIT = IMODE+100
18853         AAS = 0.D0
18854
18855 C  initialization for model 0 (gaussian pt distribution)
18856
18857         IF(INIT.EQ.0) THEN
18858           BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
18859           BETUP = BETAS(1)
18860           BETLO = -2.D0
18861           XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
18862           IF(XTOL.LT.0.D0) THEN
18863             XTOL = 1.D-4
18864             METHOD = 1
18865             MAXF = 500
18866             BETA = 0.D0
18867             BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
18868 *           IF(BETA.LT.-1.D+10) THEN
18869 *             WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18870 *    &          '(model 0: Ecm,PTcut)',EE,PTCON
18871 *             WRITE(LO,'(1X,A,1P,3E10.3)')
18872 *    &          'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18873 *             CALL PHO_PREVNT(-1)
18874 *             BETA = 0.01
18875 *           ELSE
18876               AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
18877 *           ENDIF
18878           ELSE
18879             AAS = 0.D0
18880             BETA = BETAS(1)
18881           ENDIF
18882
18883 C  initialization for model 1 (exponential pt distribution)
18884
18885         ELSE IF(INIT.EQ.1) THEN
18886           XMT = PARMDL(43)
18887           XMT2 = XMT*XMT
18888           BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
18889           BETUP = BETAS(1)
18890           BETLO = -3.D0
18891           XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
18892           IF(XTOL.LT.0.D0) THEN
18893             XTOL = 1.D-4
18894             METHOD = 1
18895             MAXF = 500
18896             BETA = 0.D0
18897             BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
18898 *           IF(BETA.LT.-1.D+10) THEN
18899 *             WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18900 *    &          '(model 1: Ecm,PTcut)',EE,PTCON
18901 *             WRITE(LO,'(1X,A,1P,3E10.3)')
18902 *    &          'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18903 *             CALL PHO_PREVNT(-1)
18904 *             BETA = 0.01
18905 *           ELSE
18906               AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
18907 *           ENDIF
18908           ELSE
18909             AAS = 0.D0
18910             BETA = BETAS(1)
18911           ENDIF
18912         ELSE IF(INIT.EQ.10) THEN
18913           IF(IDEB(5).GT.10)
18914      &      WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
18915           RETURN
18916         ELSE
18917           WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
18918      &      INIT
18919           CALL PHO_ABORT
18920         ENDIF
18921         BETA = MIN(BETA,BETAS(1))
18922
18923 C  hard cross section is too big: neg. beta parameter
18924         IF(BETA.LE.0.D0) THEN
18925           WRITE(LO,'(1X,A,1P,2E12.3)')
18926      &      'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
18927           WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
18928      &      SIGS,DSIGHP,SIGH,PTCON
18929           CALL PHO_PREVNT(-1)
18930         ENDIF
18931
18932 C  output of initialization parameters
18933         IF(IDEB(5).GE.10) THEN
18934           WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
18935      &      INIT
18936           WRITE(LO,'(5X,A,1P,2E13.3)')
18937      &      'BETA,AAS        ',BETA,AAS
18938           WRITE(LO,'(5X,A,1P,3E13.3)')
18939      &      'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
18940           WRITE(LO,'(5X,A,1P,3E13.3)')
18941      &      'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
18942         ENDIF
18943
18944       END
18945
18946 *$ CREATE PHO_CONN0.FOR
18947 *COPY PHO_CONN0
18948 CDECK  ID>, PHO_CONN0
18949       DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
18950 C***********************************************************************
18951 C
18952 C    auxiliary function to determine parameters of soft
18953 C    pt distribution  dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
18954 C
18955 C    internal factors: FS  number of soft partons in soft Pomeron
18956 C                      FH  number of soft partons in hard Pomeron
18957 C
18958 C***********************************************************************
18959       IMPLICIT NONE
18960       SAVE
18961
18962 C  input/output channels
18963       INTEGER LI,LO
18964       COMMON /POINOU/ LI,LO
18965 C  average number of cut soft and hard ladders (obsolete)
18966       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18967       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18968 C  data needed for soft-pt calculation
18969       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18970       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18971
18972       DOUBLE PRECISION BETA,XX,FF
18973
18974       XX = BETA*PTCON**2
18975       IF(ABS(XX).LT.1.D-3) THEN
18976         FF = FS*SIGS+FH*SIGH
18977      &       - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
18978       ELSE
18979         FF = FS*SIGS+FH*SIGH
18980      &       - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
18981       ENDIF
18982       PHO_CONN0 = FF
18983
18984 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
18985 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
18986
18987       END
18988
18989 *$ CREATE PHO_CONN1.FOR
18990 *COPY PHO_CONN1
18991 CDECK  ID>, PHO_CONN1
18992       DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
18993 C***********************************************************************
18994 C
18995 C    auxiliary function to determine parameters of soft
18996 C    pt distribution  dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
18997 C
18998 C    internal factors: FS  number of soft partons in soft Pomeron
18999 C                      FH  number of soft partons in hard Pomeron
19000 C
19001 C***********************************************************************
19002       IMPLICIT NONE
19003       SAVE
19004
19005 C  input/output channels
19006       INTEGER LI,LO
19007       COMMON /POINOU/ LI,LO
19008 C  average number of cut soft and hard ladders (obsolete)
19009       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19010       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19011 C  data needed for soft-pt calculation
19012       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19013       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19014
19015       DOUBLE PRECISION BETA,XX,FF
19016
19017       XX = BETA*PTCON
19018       IF(ABS(XX).LT.1.D-3) THEN
19019         FF = FS*SIGS+FH*SIGH
19020      &       - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
19021       ELSE
19022         FF = FS*SIGS+FH*SIGH
19023      &       - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19024       ENDIF
19025       PHO_CONN1 = FF
19026
19027 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19028 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19029
19030       END
19031
19032 *$ CREATE PHO_MSHELL.FOR
19033 *COPY PHO_MSHELL
19034 CDECK  ID>, PHO_MSHELL
19035       SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19036 C********************************************************************
19037 C
19038 C    rescaling of momenta of two partons to put both
19039 C                                       on mass shell
19040 C
19041 C    input:       PA1,PA2   input momentum vectors
19042 C                 XM1,2     desired masses of particles afterwards
19043 C                 P1,P2     changed momentum vectors
19044 C
19045 C********************************************************************
19046       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19047       SAVE
19048
19049       PARAMETER ( DEPS   =  1.D-20 )
19050
19051       DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19052
19053 C  input/output channels
19054       INTEGER LI,LO
19055       COMMON /POINOU/ LI,LO
19056 C  event debugging information
19057       INTEGER NMAXD
19058       PARAMETER (NMAXD=100)
19059       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19060      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19061       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19062      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19063 C  internal rejection counters
19064       INTEGER NMXJ
19065       PARAMETER (NMXJ=60)
19066       CHARACTER*10 REJTIT
19067       INTEGER IFAIL
19068       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19069
19070       IREJ = 0
19071       IDEV = 0
19072 C  debug output
19073       IF(IDEB(40).GE.10) THEN
19074         WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19075         WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19076         WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19077         WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19078       ENDIF
19079
19080 C  Lorentz transformation into system CMS
19081       PX = PA1(1)+PA2(1)
19082       PY = PA1(2)+PA2(2)
19083       PZ = PA1(3)+PA2(3)
19084       EE = PA1(4)+PA2(4)
19085       XMS = EE**2-PX**2-PY**2-PZ**2
19086       IF(XMS.LT.(XM1+XM2)**2) THEN
19087         IREJ = 1
19088         IFAIL(37) = IFAIL(37)+1
19089
19090         if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19091
19092         IF(IDEB(40).GE.3) THEN
19093           WRITE(LO,'(/1X,A,I12)')
19094      &      'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19095           WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19096      &      SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19097           WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19098           IDEV = 5
19099           IF(IDEB(40).GE.3) GOTO 55
19100         ENDIF
19101         RETURN
19102       ENDIF
19103       XMS = SQRT(XMS)
19104       BGX = PX/XMS
19105       BGY = PY/XMS
19106       BGZ = PZ/XMS
19107       GAM = EE/XMS
19108       CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19109      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19110 C  rotation angles
19111       PTOT1 = MAX(DEPS,PTOT1)
19112       COD = P1(3)/PTOT1
19113       SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19114       COF = 1.D0
19115       SIF = 0.D0
19116       IF(PTOT1*SID.GT.1.D-5) THEN
19117         COF = P1(1)/(SID*PTOT1)
19118         SIF = P1(2)/(SID*PTOT1)
19119         ANORF = SQRT(COF*COF+SIF*SIF)
19120         COF = COF/ANORF
19121         SIF = SIF/ANORF
19122       ENDIF
19123
19124 C  new CM momentum and energies (for masses XM1,XM2)
19125       XM12 = XM1**2
19126       XM22 = XM2**2
19127       SS   = XMS**2
19128       PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19129       EE1  = SQRT(XM12+PCMP**2)
19130       EE2  = XMS-EE1
19131 C  back rotation
19132       CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19133       CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19134      &           PTOT1,P1(1),P1(2),P1(3),P1(4))
19135       CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19136      &           PTOT2,P2(1),P2(2),P2(3),P2(4))
19137
19138 C  check consistency
19139       DEL = XMS*0.0001
19140       IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19141         IDEV = 1
19142       ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19143         IDEV = 2
19144       ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19145         IDEV = 3
19146       ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19147         IDEV = 4
19148       ENDIF
19149  55   CONTINUE
19150 C  debug output
19151       IF(IDEV.NE.0) THEN
19152         WRITE(LO,'(1X,A,I3)')
19153      &    'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19154         WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19155         WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19156         WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19157         WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19158         WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19159         WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19160         WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19161       ELSE IF(IDEB(40).GE.10) THEN
19162         WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19163         WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19164         WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19165       ENDIF
19166       END
19167
19168 *$ CREATE PHO_GLU2QU.FOR
19169 *COPY PHO_GLU2QU
19170 CDECK  ID>, PHO_GLU2QU
19171       SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19172 C********************************************************************
19173 C
19174 C    split gluon with index I in POEVT1
19175 C          (massless gluon assumed)
19176 C
19177 C    input:      /POEVT1/
19178 C                IG      gluon index
19179 C                IQ1     first quark index
19180 C                IQ2     second quark index
19181 C
19182 C    output:     new quarks in /POEVT1/
19183 C                IREJ    1 splitting impossible
19184 C                        0 splitting successful
19185 C
19186 C********************************************************************
19187       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19188       SAVE
19189
19190       PARAMETER ( DEPS   =  1.D-15,
19191      &            EPS    =  1.D-5 )
19192
19193 C  input/output channels
19194       INTEGER LI,LO
19195       COMMON /POINOU/ LI,LO
19196 C  event debugging information
19197       INTEGER NMAXD
19198       PARAMETER (NMAXD=100)
19199       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19200      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19201       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19202      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19203 C  model switches and parameters
19204       CHARACTER*8 MDLNA
19205       INTEGER ISWMDL,IPAMDL
19206       DOUBLE PRECISION PARMDL
19207       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19208 C  standard particle data interface
19209       INTEGER NMXHEP
19210       PARAMETER (NMXHEP=4000)
19211       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19212       DOUBLE PRECISION PHEP,VHEP
19213       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19214      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19215      &                VHEP(4,NMXHEP)
19216 C  extension to standard particle data interface (PHOJET specific)
19217       INTEGER IMPART,IPHIST,ICOLOR
19218       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19219 C  internal rejection counters
19220       INTEGER NMXJ
19221       PARAMETER (NMXJ=60)
19222       CHARACTER*10 REJTIT
19223       INTEGER IFAIL
19224       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19225
19226       DIMENSION P1(4),P2(4)
19227       DATA CUTM  /0.02D0/
19228
19229       IREJ = 0
19230
19231 C  calculate string masses max possible
19232       IF(ISWMDL(9).EQ.1) THEN
19233         CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19234      &     -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19235         IF(CMASS1.LT.CUTM) THEN
19236           IF(IDEB(73).GE.5) THEN
19237             WRITE(LO,'(1X,A,3I4,4E10.3)')
19238      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19239           ENDIF
19240           IFAIL(33) = IFAIL(33) + 1
19241           IREJ = 1
19242           RETURN
19243         ENDIF
19244         CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19245      &     -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19246         IF(CMASS2.LT.CUTM) THEN
19247           IF(IDEB(73).GE.5) THEN
19248             WRITE(LO,'(1X,A,3I4,4E10.3)')
19249      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19250           ENDIF
19251           IFAIL(33) = IFAIL(33) + 1
19252           IREJ = 1
19253           RETURN
19254         ENDIF
19255 C
19256 C  calculate minimal z
19257         ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19258         ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19259         ZMIN = MIN(ZMIN1,ZMIN2)
19260         IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19261           IF(IDEB(73).GE.5) THEN
19262             WRITE(LO,'(1X,A,3I3,4E10.3)')
19263      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19264      &        IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19265           ENDIF
19266           IFAIL(33) = IFAIL(33) + 1
19267           IREJ = 1
19268           RETURN
19269         ENDIF
19270       ELSE
19271         ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19272       ENDIF
19273 C
19274       ZFRAC = PHO_GLUSPL(ZMIN)
19275       IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19276         ZFRAC = 1.D0-ZFRAC
19277       ENDIF
19278       DO 200 I=1,4
19279         P1(I) = PHEP(I,IG)*ZFRAC
19280         P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19281  200  CONTINUE
19282 C  quark flavours
19283       CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19284       CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19285      &              +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19286       CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19287       IF(ABS(IDHEP(IQ1)).GT.6) THEN
19288         K = SIGN(ABS(K),IDHEP(IQ1))
19289       ELSE
19290         K = -SIGN(ABS(K),IDHEP(IQ1))
19291       ENDIF
19292 C  colors
19293       IF(K.GT.0) THEN
19294         IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19295         IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19296       ELSE
19297         IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19298         IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19299       ENDIF
19300 C  register new partons
19301       CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19302      &            IPHIST(1,IG),0,IC1,0,IPOS,1)
19303       CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19304      &            IPHIST(1,IG),0,IC2,0,IPOS,1)
19305 C  debug output
19306       IF(IDEB(73).GE.20) THEN
19307           WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19308      &      'PHO_GLU2QU:','   IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19309      &      IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19310         WRITE(LO,'(1X,A,4I5)') '   flavours, colors  ',
19311      &    K,-K,IC1,IC2
19312       ENDIF
19313       END
19314
19315 *$ CREATE PHO_GLUSPL.FOR
19316 *COPY PHO_GLUSPL
19317 CDECK  ID>, PHO_GLUSPL
19318       DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19319 C*********************************************************************
19320 C
19321 C     calculate quark - antiquark light cone momentum fractions
19322 C     according to Altarelli-Parisi g->q aq splitting function
19323 C     (symmetric z interval assumed)
19324 C
19325 C     input: ZMIN    minimal Z value allowed,
19326 C                    1-ZMIN maximal Z value allowed
19327 C
19328 C********************************************************************
19329       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19330       SAVE
19331
19332       PARAMETER ( ALEXP= 0.3333333333D0,
19333      &            DEPS = 1.D-10 )
19334
19335 C  input/output channels
19336       INTEGER LI,LO
19337       COMMON /POINOU/ LI,LO
19338 C  event debugging information
19339       INTEGER NMAXD
19340       PARAMETER (NMAXD=100)
19341       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19342      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19343       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19344      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19345
19346       IF(ZMIN.GE.0.5D0) THEN
19347         IF(IDEB(69).GT.2) THEN
19348           WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19349         ENDIF
19350         ZZ=0.D0
19351         GOTO 1000
19352       ELSE IF(ZMIN.LE.0.D0) THEN
19353         IF(IDEB(69).GT.2) THEN
19354           WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19355         ENDIF
19356         ZMINL = DEPS
19357       ELSE
19358         ZMINL = ZMIN
19359       ENDIF
19360
19361       ZMAX = 1.D0-ZMINL
19362       XI   = DT_RNDM(ZMAX)
19363       ZZ   = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19364       IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19365
19366  1000 CONTINUE
19367       IF(IDEB(69).GE.10) THEN
19368         WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19369       ENDIF
19370       PHO_GLUSPL = ZZ
19371       END
19372
19373 *$ CREATE PHO_STDPAR.FOR
19374 *COPY PHO_STDPAR
19375 CDECK  ID>, PHO_STDPAR
19376       SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19377 C***********************************************************************
19378 C
19379 C     select the initial parton x-fractions and flavors and
19380 C     the final parton momenta and flavours
19381 C     for standard Pomeron/Reggeon cuts
19382 C
19383 C     input:   IJM1   index of mother particle 1 in /POEVT1/
19384 C              IJM2   index of mother particle 2 in /POEVT1/
19385 C              IGEN   production process of mother particles
19386 C              MSPOM  soft cut Pomerons
19387 C              MHPOM  hard or semihard cut Pomerons
19388 C              MSREG  soft cut Reggeons
19389 C              MHDIR  direct hard processes
19390 C
19391 C              IJM1   -1    initialization of statistics
19392 C                     -2    output of statistics
19393 C
19394 C     output:  partons are directly written to /POEVT1/,/POEVT2/
19395 C
19396 C          structure of /POSOFT/
19397 C               XS1(I),XS2(I):     x-values of initial partons
19398 C               IJSI1(I),IJSI2(I): flavor of initial parton
19399 C                                  0            gluon
19400 C                                  1,2,3,4      quarks
19401 C                                  negative     antiquarks
19402 C               IJSF1(I),IJSF2(I): flavor of final state partons
19403 C               PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19404 C                                J=1   PX
19405 C                                 =2   PY
19406 C                                 =3   PZ
19407 C                                 =4   ENERGY
19408 C
19409 C***********************************************************************
19410       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19411       SAVE
19412
19413       PARAMETER (RHOMAS =  0.766D0,
19414      &           DEPS   =  1.D-10,
19415      &           TINY   =  1.D-10)
19416
19417 C  input/output channels
19418       INTEGER LI,LO
19419       COMMON /POINOU/ LI,LO
19420 C  event debugging information
19421       INTEGER NMAXD
19422       PARAMETER (NMAXD=100)
19423       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19424      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19425       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19426      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19427 C  model switches and parameters
19428       CHARACTER*8 MDLNA
19429       INTEGER ISWMDL,IPAMDL
19430       DOUBLE PRECISION PARMDL
19431       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19432 C  some constants
19433       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19434       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19435      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19436 C  general process information
19437       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19438       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19439 C  global event kinematics and particle IDs
19440       INTEGER IFPAP,IFPAB
19441       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19442       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19443 C  data of c.m. system of Pomeron / Reggeon exchange
19444       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19445       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19446      &                 SIDP,CODP,SIFP,COFP
19447       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19448      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
19449      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
19450 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
19451       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19452       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19453       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19454      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19455 C  obsolete cut-off information
19456       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19457       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19458 C  currently activated parton density parametrizations
19459       CHARACTER*8 PDFNAM
19460       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19461       DOUBLE PRECISION PDFLAM,PDFQ2M
19462       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19463      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19464 C  hard scattering parameters used for most recent hard interaction
19465       INTEGER NFbeta,NF
19466       DOUBLE PRECISION ALQCD2,BQCD
19467       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19468 C  particles created by initial state evolution
19469       INTEGER MXISR1,MXISR2
19470       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19471       INTEGER IFLISR,IPOISR,IMXISR
19472       DOUBLE PRECISION PHISR
19473       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19474      &                IPOISR(2,2,MXISR2),IMXISR(2)
19475 C  light-cone x fractions and c.m. momenta of soft cut string ends
19476       INTEGER MAXSOF
19477       PARAMETER ( MAXSOF = 50 )
19478       INTEGER IJSI2,IJSI1
19479       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19480       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19481      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19482      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
19483 C  table of particle indices for recursive PHOJET calls
19484       INTEGER MAXIPX
19485       PARAMETER ( MAXIPX = 100 )
19486       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19487       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19488      &                IPOIX1,IPOIX2,IPOIX3
19489 C  hard scattering data
19490       INTEGER MSCAHD
19491       PARAMETER ( MSCAHD = 50 )
19492       INTEGER LSCAHD,LSC1HD,LSIDX,
19493      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19494       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19495       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19496      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19497      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19498      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19499      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19500      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19501      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19502 C  standard particle data interface
19503       INTEGER NMXHEP
19504       PARAMETER (NMXHEP=4000)
19505       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19506       DOUBLE PRECISION PHEP,VHEP
19507       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19508      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19509      &                VHEP(4,NMXHEP)
19510 C  extension to standard particle data interface (PHOJET specific)
19511       INTEGER IMPART,IPHIST,ICOLOR
19512       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19513 C  internal rejection counters
19514       INTEGER NMXJ
19515       PARAMETER (NMXJ=60)
19516       CHARACTER*10 REJTIT
19517       INTEGER IFAIL
19518       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19519 C  internal cross check information on hard scattering limits
19520       DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19521       COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19522 C  hard cross sections and MC selection weights
19523       INTEGER Max_pro_2
19524       PARAMETER ( Max_pro_2 = 16 )
19525       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19526      &  MH_acc_1,MH_acc_2
19527       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19528       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19529      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19530      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19531      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19532      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19533
19534       double precision pho_alphas
19535
19536       DIMENSION PC(4),IFLA(2),ICI(2,2)
19537
19538       IF(IJM1.EQ.-1) THEN
19539         DO 116 I=1,15
19540           ETAMI(1,I) = 1.D10
19541           ETAMA(1,I) = -1.D10
19542           ETAMI(2,I) = 1.D10
19543           ETAMA(2,I) = -1.D10
19544           XXMI(1,I) = 1.D0
19545           XXMA(1,I) = 0.D0
19546           XXMI(2,I) = 1.D0
19547           XXMA(2,I) = 0.D0
19548  116    CONTINUE
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
19554       ELSE IF(IJM1.EQ.-2) THEN
19555
19556 C  output internal statistics
19557         IF(IDEB(23).GE.1) THEN
19558           WRITE(LO,'(/1X,A)')
19559      &      'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19560           DO 117 I=1,15
19561             WRITE(LO,'(5X,I3,4E13.5)')
19562      &        I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19563  117      CONTINUE
19564           WRITE(LO,'(1X,A)')
19565      &      'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19566           DO 118 I=1,15
19567             WRITE(LO,'(5X,I3,4E13.5)')
19568      &        I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
19569  118      CONTINUE
19570         ENDIF
19571         CALL PHO_HARSCA(IJM1,1)
19572         CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19573
19574         RETURN
19575       ENDIF
19576
19577       IREJ   = 0
19578 C  debug output
19579       IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19580   221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19581
19582 C  get mother data (exchange if first particle is a pomeron)
19583       IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19584         JM1 = IJM2
19585         JM2 = IJM1
19586       ELSE
19587         JM1 = IJM1
19588         JM2 = IJM2
19589       ENDIF
19590
19591       NPOSP(1) = JM1
19592       NPOSP(2) = JM2
19593       IDPDG1 = IDHEP(JM1)
19594       IDBAM1 = IMPART(JM1)
19595       IDPDG2 = IDHEP(JM2)
19596       IDBAM2 = IMPART(JM2)
19597
19598 C  store current status of /POEVT1/
19599       KHPOMS = KHPOM
19600       KSPOMS = KSPOM
19601       KSREGS = KSREG
19602       KHDIRS = KHDIR
19603       NHEPS  = NHEP
19604       IPOIS1 = IPOIX1
19605       IPOIS2 = IPOIX2
19606
19607 C  get nominal masses (photons: VDM assumption)
19608       DELMAS = 0.D0
19609       IF(IDHEP(JM1).EQ.22) THEN
19610         PMASSP(1) = RHOMAS+DELMAS
19611         PVIRTP(1) = PHEP(5,JM1)**2
19612       ELSE
19613         PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19614         PVIRTP(1) = 0.D0
19615       ENDIF
19616       IF(IDHEP(JM2).EQ.22) THEN
19617         PMASSP(2) = RHOMAS+DELMAS
19618         PVIRTP(2) = PHEP(5,JM2)**2
19619       ELSE
19620         PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19621         PVIRTP(2) = 0.D0
19622       ENDIF
19623
19624 C  calculate c.m. energy and check kinematics
19625       PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19626       PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19627       PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19628       PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19629       SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19630
19631       IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19632         WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19633      &    'energy smaller than two-particle threshold (event rejected)'
19634         CALL PHO_PREVNT(1)
19635         IREJ = 5
19636         GOTO 150
19637       ENDIF
19638       ECMP = SQRT(SS)
19639
19640       IF(IDEB(23).GE.5) THEN
19641         WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19642      &    'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19643         IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19644       ENDIF
19645
19646 C  Lorentz transformation into c.m. system
19647       DO 10 I=1,4
19648         GAMBEP(I) = PC(I)/ECMP
19649  10   CONTINUE
19650       CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19651      &           PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19652      &           PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19653 C  rotation angle: particle 1 moves along +z
19654       CODP = PC(3)/PTOT1
19655       SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19656       COFP = 1.D0
19657       SIFP = 0.D0
19658       IF(PTOT1*SIDP.GT.1.D-5) THEN
19659         COFP = PC(1)/(SIDP*PTOT1)
19660         SIFP = PC(2)/(SIDP*PTOT1)
19661         ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19662         COFP = COFP/ANORF
19663         SIFP = SIFP/ANORF
19664       ENDIF
19665 C  get CM momentum
19666       XM12 = PMASSP(1)**2
19667       XM22 = PMASSP(2)**2
19668       PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19669
19670 C  find particle combination
19671       II = 0
19672       IF(IDPDG2.EQ.IFPAP(2)) THEN
19673         IF(IDPDG1.EQ.IFPAP(1)) II = 1
19674       ELSE IF(IDPDG2.EQ.990) THEN
19675         IF(IDPDG1.EQ.IFPAP(1)) THEN
19676           II = 2
19677         ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19678           II = 3
19679         ELSE IF(IDPDG1.EQ.990) THEN
19680           II = 4
19681         ENDIF
19682       ENDIF
19683       IF(II.EQ.0) THEN
19684         IF(ISWMDL(14).GT.0) THEN
19685           II = 1
19686         ELSE
19687           WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19688      &      'invalid particle combination:',IDPDG1,IDPDG2
19689           CALL PHO_ABORT
19690         ENDIF
19691       ENDIF
19692
19693 C  select parton distribution functions from tables
19694       IF((MHPOM+MHDIR).GT.0) THEN
19695         CALL PHO_ACTPDF(IDPDG1,1)
19696         CALL PHO_ACTPDF(IDPDG2,2)
19697 C  initialize alpha_s calculation
19698         DUMMY = PHO_ALPHAS(0.D0,-4)
19699       ENDIF
19700
19701 C  interpolate hard cross sections and rejection weights
19702       CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19703      &            -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19704
19705       NTRY   = 10
19706
19707 C  position of first particle added to /POEVT2/
19708       NLOR1 = NHEP+1
19709
19710 C  ---------------- direct processes -----------------
19711
19712       IF(MHDIR.EQ.1) THEN
19713         CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19714         IF(IREJ.EQ.50) RETURN
19715         IF(IREJ.NE.0) GOTO 150
19716 C  write comments to /POEVT1/
19717         CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19718      &    X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19719      &    IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19720         CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19721      &    PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19722      &    ICA1,ICA2,IPOS,1)
19723         CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19724      &    PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19725      &    ICA1,ICA2,IPOS,1)
19726         CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19727      &    PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19728      &    IPOS1,1)
19729         CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19730      &    PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19731      &    IPOS2,1)
19732
19733 C  soft spectator partons
19734         ICA1  = 0
19735         ICA2  = 0
19736         ICB1  = 0
19737         ICB2  = 0
19738         IPDF1 = 0
19739         IPDF2 = 0
19740
19741 C  single resolved: QCD compton scattering
19742 C ------------------------------
19743         IF(NPROHD(1).EQ.10) THEN
19744 C  register hadron remnant
19745           CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19746           IPDF2 = 1000*IGRP(2)+ISET(2)
19747         ELSE IF(NPROHD(1).EQ.12) THEN
19748 C  register hadron remnant
19749           CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19750           IPDF1 = 1000*IGRP(1)+ISET(1)
19751
19752 C  single resolved: photon gluon fusion
19753 C ---------------------------
19754         ELSE IF(NPROHD(1).EQ.11) THEN
19755 C  register hadron remnant
19756           CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19757           IPDF2 = 1000*IGRP(2)+ISET(2)
19758         ELSE IF(NPROHD(1).EQ.13) THEN
19759 C  register hadron remnant
19760           CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19761           IPDF1 = 1000*IGRP(1)+ISET(1)
19762
19763 C  direct process (no remnant)
19764 C ----------------------------
19765         ELSE IF(NPROHD(1).EQ.14) THEN
19766
19767         ENDIF
19768
19769 C  write final high-pt partons to POEVT1
19770         IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19771           ICI(1,1) = ICA1
19772           ICI(1,2) = ICA2
19773           ICI(2,1) = ICB1
19774           ICI(2,2) = ICB2
19775           I = 1
19776           IFLA(1) = NINHD(I,1)
19777           IFLA(2) = NINHD(I,2)
19778 C  initial state radiation
19779           DO 130 K=1,2
19780             DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19781               KK = 1
19782  137          CONTINUE
19783               IFLB = IFLISR(K,IPA)
19784               IF(ABS(IFLB).LE.6) THEN
19785 C  partons
19786                 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19787                   IF(IFLB.EQ.0) THEN
19788                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19789      &                ICI(K,1),ICI(K,2),3)
19790                   ELSE IF(IFLB.GT.0) THEN
19791                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19792      &                ICI(K,1),ICI(K,2),4)
19793                   ELSE
19794                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19795      &                IC1,IC2,4)
19796                   ENDIF
19797                 ELSE
19798                   IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19799                     IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19800                       CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19801                       KK = KK+1
19802                       GOTO 137
19803                     ENDIF
19804                   ENDIF
19805                   IF(IFLB.EQ.0) THEN
19806                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19807      &                IC1,IC2,2)
19808                   ELSE
19809                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19810      &                ICI(K,1),ICI(K,2),2)
19811                   ENDIF
19812                 ENDIF
19813                 IIFL = IPHO_CNV1(IFLB)
19814                 IFLA(K) = IFLA(K)-IFLB
19815                 IST = -1
19816               ELSE
19817 C  other particle
19818                 IIFL = IFLB
19819                 IC1 = 0
19820                 IC2 = 0
19821                 IST = 1
19822               ENDIF
19823               CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
19824      &          PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
19825      &          IGEN,IC1,IC2,IPOS,1)
19826  135        CONTINUE
19827  130      CONTINUE
19828           ICOLOR(1,IPOS1-2) = ICI(1,1)
19829           ICOLOR(2,IPOS1-2) = ICI(1,2)
19830           ICOLOR(1,IPOS1-1) = ICI(2,1)
19831           ICOLOR(2,IPOS1-1) = ICI(2,2)
19832           CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
19833      &      IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
19834      &      NOUTHD(I,2),ICI(2,1),ICI(2,2))
19835           ICOLOR(1,IPOS1) = ICI(1,1)
19836           ICOLOR(2,IPOS1) = ICI(1,2)
19837           ICOLOR(1,IPOS2) = ICI(2,1)
19838           ICOLOR(2,IPOS2) = ICI(2,2)
19839           DO 140 K=1,2
19840             IPA = IPOISR(K,1,I)
19841             CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
19842      &        PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
19843      &        PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
19844  140      CONTINUE
19845         ELSE
19846           ICOLOR(1,IPOS1-2) = ICA1
19847           ICOLOR(2,IPOS1-2) = ICA2
19848           ICOLOR(1,IPOS1-1) = ICB1
19849           ICOLOR(2,IPOS1-1) = ICB2
19850           CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
19851      &      NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
19852      &      NOUTHD(1,2),ICB1,ICB2)
19853           ICOLOR(1,IPOS1) = ICA1
19854           ICOLOR(2,IPOS1) = ICA2
19855           ICOLOR(1,IPOS2) = ICB1
19856           ICOLOR(2,IPOS2) = ICB2
19857           I = -1
19858           IF(ABS(NOUTHD(1,1)).GT.12) I = 1
19859           CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
19860      &      PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
19861           CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
19862      &      PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
19863         ENDIF
19864
19865 C  assign soft pt to spectators
19866         IF(ISWMDL(18).EQ.0) THEN
19867           IPOS2 = IPOS2-1
19868           CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
19869           IF(IREJ.NE.0) THEN
19870             IFAIL(26) = IFAIL(26) + 1
19871             GOTO 150
19872           ENDIF
19873
19874         ENDIF
19875
19876 C  ----------------- resolved processes -------------------
19877
19878 C  single Reggeon exchange
19879 C ----------------------------
19880       ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
19881 C  flavours
19882         CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
19883         IF(IREJ.NE.0) THEN
19884           IFAIL(24) = IFAIL(24)+1
19885           GOTO 150
19886         ENDIF
19887 C  colors
19888         CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19889         IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
19890      &     .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
19891           CALL PHO_SWAPI(ICA1,ICB1)
19892         ENDIF
19893         ECMH = ECMP/2.D0
19894
19895 C  registration
19896
19897 C  DPMJET call with special projectile / target
19898         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
19899           CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
19900      &               ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
19901           CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
19902      &               ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
19903 C  default treatment
19904         ELSE
19905           CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
19906      &      -1,IGEN,ICA1,0,IPOS1,1)
19907           CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
19908      &      -1,IGEN,ICB1,0,IPOS2,1)
19909         ENDIF
19910
19911 C  soft pt assignment
19912         IF(ISWMDL(18).EQ.0) THEN
19913           CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19914           IF(IREJ.NE.0) THEN
19915             IFAIL(25) = IFAIL(25) + 1
19916             GOTO 150
19917           ENDIF
19918         ENDIF
19919 C
19920 C  multi Reggeon / Pomeron exchange
19921 C----------------------------------------
19922       ELSE
19923 C  parton configuration
19924
19925         CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
19926      &              MHPAR1,MHPAR2,IREJ)
19927
19928         IF(IREJ.EQ.50) RETURN
19929         IF(IREJ.NE.0) GOTO 150
19930
19931 C  register particles
19932         IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
19933      &    'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
19934      &    MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
19935
19936 C  register soft partons
19937         IF(IVAL1.NE.0) THEN
19938           IF(IVAL1.LT.0) THEN
19939             IND1 = 3
19940             IVAL1=-IVAL1
19941           ELSE
19942             IND1 = 2
19943           ENDIF
19944         ELSE IF(MSPOM.EQ.0) THEN
19945           IND1 = 4
19946         ELSE
19947           IND1 = 1
19948         ENDIF
19949         IF(IVAL2.NE.0) THEN
19950           IF(IVAL2.LT.0) THEN
19951             IND2 = 3
19952             IVAL2=-IVAL2
19953           ELSE
19954             IND2 = 2
19955           ENDIF
19956         ELSE IF(MSPOM.EQ.0) THEN
19957           IND2 = 4
19958         ELSE
19959           IND2 = 1
19960         ENDIF
19961
19962         IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
19963      &    'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
19964
19965 C  soft Pomeron final states
19966 C -----------------------------------
19967         K = MSPOM+MHPOM+MSREG
19968         DO 50 I=1,MSPOM
19969
19970           CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
19971           IF(IREJ.NE.0) THEN
19972             IFAIL(8) = IFAIL(8) + 1
19973             GOTO 150
19974           ENDIF
19975 C
19976  50     CONTINUE
19977
19978 C  soft Reggeon final states
19979 C -----------------------------------------
19980         DO 75 I=1,MSREG
19981 C  flavours
19982           CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
19983           IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
19984             CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
19985           ELSE
19986             CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
19987           ENDIF
19988 C  colors
19989           CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19990           IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
19991      &      .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
19992      &      CALL PHO_SWAPI(ICA1,ICB1)
19993 C  registration
19994           CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
19995      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
19996      &      I,IGEN,ICA1,ICA2,IPOS1,1)
19997           IND1 = IND1+1
19998           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
19999      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
20000      &      I,IGEN,ICB1,ICB2,IPOS2,1)
20001           IND2 = IND2+1
20002
20003           IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
20004      &      'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
20005      &      IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
20006
20007 C  soft pt assignment
20008           IF(ISWMDL(18).EQ.0) THEN
20009             CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20010             IF(IREJ.NE.0) THEN
20011               IFAIL(25) = IFAIL(25) + 1
20012               GOTO 150
20013             ENDIF
20014           ENDIF
20015
20016  75     CONTINUE
20017
20018 C  hard Pomeron final states
20019 C ------------------------------------
20020         IND1 = MSPAR1
20021         IND2 = MSPAR2
20022
20023         DO 100 L=1,MHPOM
20024           I = LSIDX(L)
20025
20026           IFLI1 = IPHO_CNV1(N0INHD(I,1))
20027           IFLI2 = IPHO_CNV1(N0INHD(I,2))
20028           IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20029           IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20030 C  write comments to /POEVT1/
20031           CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20032      &      X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20033      &      IFLO1,IFLO2,IPOS,1)
20034           I1 = 8*I-7
20035           IPDF = 1000*IGRP(1)+ISET(1)
20036           CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20037      &      PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20038      &      ICA1,ICA2,IPOS,1)
20039           IPDF = 1000*IGRP(2)+ISET(2)
20040           CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20041      &      PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20042      &      ICB1,ICB2,IPOS,1)
20043           I1 = 8*I-3
20044           IPDF = 1000*IGRP(1)+ISET(1)
20045           CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20046      &      PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20047      &      ICA1,ICA2,IPOS1,1)
20048           IPDF = 1000*IGRP(2)+ISET(2)
20049           CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20050      &      PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20051      &      ICB1,ICB2,IPOS2,1)
20052
20053 C  spectator partons belonging to hard interaction
20054           IF(IVAL1.EQ.I) THEN
20055             IVQ = 1
20056             IND = 1
20057           ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20058             IVQ = 0
20059             IND = 1
20060           ELSE
20061             IVQ = -1
20062             IND = IND1
20063           ENDIF
20064           CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20065           IF(IVQ.LT.0) IND1 = IND1-IUSED
20066           IF(IVAL2.EQ.I) THEN
20067             IVQ = 1
20068             IND = 1
20069           ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20070             IVQ = 0
20071             IND = 1
20072           ELSE
20073             IVQ = -1
20074             IND = IND2
20075           ENDIF
20076           CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20077           IF(IVQ.LT.0) IND2 = IND2-IUSED
20078 C
20079 C  register hard scattered partons
20080           IF((ISWMDL(8).GE.2)
20081      &       .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20082             ICI(1,1) = ICA1
20083             ICI(1,2) = ICA2
20084             ICI(2,1) = ICB1
20085             ICI(2,2) = ICB2
20086             IFLA(1) = NINHD(I,1)
20087             IFLA(2) = NINHD(I,2)
20088 C  initial state radiation
20089             DO 230 K=1,2
20090               DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20091                 KK = 1
20092  237            CONTINUE
20093                 IFLB = IFLISR(K,IPA)
20094                 IF(ABS(IFLB).LE.6) THEN
20095 C  partons
20096                   IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20097                     IF(IFLB.EQ.0) THEN
20098                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20099      &                  ICI(K,1),ICI(K,2),3)
20100                     ELSE IF(IFLB.GT.0) THEN
20101                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20102      &                  ICI(K,1),ICI(K,2),4)
20103                     ELSE
20104                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20105      &                  ICI(K,2),IC1,IC2,4)
20106                     ENDIF
20107                   ELSE
20108                     IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20109                       IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20110                         CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20111                         KK = KK+1
20112                         GOTO 237
20113                       ENDIF
20114                     ENDIF
20115                     IF(IFLB.EQ.0) THEN
20116                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20117      &                  ICI(K,2),IC1,IC2,2)
20118                     ELSE
20119                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20120      &                  ICI(K,1),ICI(K,2),2)
20121                     ENDIF
20122                   ENDIF
20123                   IIFL = IPHO_CNV1(IFLB)
20124                   IFLA(K)  = IFLA(K)-IFLB
20125                   IST = -1
20126                 ELSE
20127 C  other particles
20128                   IIFL = IFLB
20129                   IC1 = 0
20130                   IC2 = 0
20131                   IST = 1
20132                 ENDIF
20133                 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20134      &            PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20135      &            L*100+K,IGEN,IC1,IC2,IPOS,1)
20136  235          CONTINUE
20137  230        CONTINUE
20138             ICOLOR(1,IPOS1-2) = ICI(1,1)
20139             ICOLOR(2,IPOS1-2) = ICI(1,2)
20140             ICOLOR(1,IPOS1-1) = ICI(2,1)
20141             ICOLOR(2,IPOS1-1) = ICI(2,2)
20142             CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20143      &        IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20144      &        NOUTHD(I,2),ICI(2,1),ICI(2,2))
20145             ICOLOR(1,IPOS1) = ICI(1,1)
20146             ICOLOR(2,IPOS1) = ICI(1,2)
20147             ICOLOR(1,IPOS2) = ICI(2,1)
20148             ICOLOR(2,IPOS2) = ICI(2,2)
20149             DO 240 K=1,2
20150               IPA = IPOISR(K,1,I)
20151               CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20152      &          PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20153      &          PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20154  240        CONTINUE
20155           ELSE
20156             ICOLOR(1,IPOS1-2) = ICA1
20157             ICOLOR(2,IPOS1-2) = ICA2
20158             ICOLOR(1,IPOS1-1) = ICB1
20159             ICOLOR(2,IPOS1-1) = ICB2
20160             CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20161      &        NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20162      &        NOUTHD(I,2),ICB1,ICB2)
20163             ICOLOR(1,IPOS1) = ICA1
20164             ICOLOR(2,IPOS1) = ICA2
20165             ICOLOR(1,IPOS2) = ICB1
20166             ICOLOR(2,IPOS2) = ICB2
20167             I1 = 8*I-3
20168             CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20169      &        PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20170      &        ICA1,ICA2,IPOS,1)
20171             CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20172      &        PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20173      &        ICB1,ICB2,IPOS,1)
20174           ENDIF
20175  100    CONTINUE
20176 C  end of resolved parton registration
20177       ENDIF
20178
20179       IF(MHDIR+MHPOM.GT.0) THEN
20180
20181         IF(ISWMDL(29).GE.1) THEN
20182 C  primordial kt of hard scattering
20183           CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20184           IF(IREJ.NE.0) THEN
20185             IFAIL(27) = IFAIL(27)+1
20186             GOTO 150
20187           ENDIF
20188         ELSE IF(ISWMDL(24).GE.0) THEN
20189 C  give "soft" pt only to soft (spectator) partons in hard processes
20190           CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20191           IF(IREJ.NE.0) THEN
20192             IFAIL(26) = IFAIL(26)+1
20193             GOTO 150
20194           ENDIF
20195         ENDIF
20196
20197       ENDIF
20198
20199 C  give "soft" pt to partons in soft Pomerons
20200       IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20201         CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20202         IF(IREJ.NE.0) THEN
20203           IFAIL(25) = IFAIL(25) + 1
20204           GOTO 150
20205         ENDIF
20206       ENDIF
20207
20208 C  boost back to lab frame
20209       CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20210      &  GAMBEP(1),GAMBEP(2),GAMBEP(3))
20211       RETURN
20212
20213 C  rejection treatment
20214  150  CONTINUE
20215       IFAIL(2) = IFAIL(2)+1
20216 C  reset counters
20217       KSPOM = KSPOMS
20218       KHPOM = KHPOMS
20219       KHDIR = KHDIRS
20220       KSREG = KSREGS
20221 C  reset mother-daugther relations
20222       JDAHEP(1,JM1) = 0
20223       JDAHEP(2,JM1) = 0
20224       JDAHEP(1,JM2) = 0
20225       JDAHEP(2,JM2) = 0
20226       ISTHEP(JM1) = 1
20227       ISTHEP(JM2) = 1
20228       IPOIX1 = IPOIS1
20229       IPOIX2 = IPOIS2
20230       NHEP   = NHEPS
20231 C  debug
20232       IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20233      &  'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20234      &  MSPOM,MHPOM,MSREG,MHDIR
20235       RETURN
20236
20237       END
20238
20239 *$ CREATE PHO_HARCOL.FOR
20240 *COPY PHO_HARCOL
20241 CDECK  ID>, PHO_HARCOL
20242       SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20243      &                  IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20244 C*********************************************************************
20245 C
20246 C     calculate color flow for hard resolved process
20247 C
20248 C     input:    IP1..4  flavour of partons (PDG convention)
20249 C               V       parton subprocess Mandelstam variable  V = t/s
20250 C                       (lightcone momenta assumed)
20251 C               ICA,ICB color labels
20252 C               MSPR    process number
20253 C                       -1   initialization of statistics
20254 C                       -2   output of statistics
20255 C
20256 C     output:   ICC,ICD color label of final partons
20257 C
20258 C     (it is possible to use the same variables for in and output)
20259 C
20260 C**********************************************************************
20261       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20262       SAVE
20263
20264 C  input/output channels
20265       INTEGER LI,LO
20266       COMMON /POINOU/ LI,LO
20267 C  event debugging information
20268       INTEGER NMAXD
20269       PARAMETER (NMAXD=100)
20270       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20271      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20272       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20273      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20274 C  model switches and parameters
20275       CHARACTER*8 MDLNA
20276       INTEGER ISWMDL,IPAMDL
20277       DOUBLE PRECISION PARMDL
20278       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20279 C  names of hard scattering processes
20280       INTEGER Max_pro_1
20281       PARAMETER ( Max_pro_1 = 16 )
20282       CHARACTER*18 PROC
20283       COMMON /POHPRO/ PROC(0:Max_pro_1)
20284
20285       DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20286
20287 C  initialization
20288       IF(MSPR.EQ.-1) THEN
20289         DO 200 I=1,8
20290           DO 210 K=1,5
20291             ICONF(I,K) = 0
20292  210      CONTINUE
20293           IRECN(I,1) = 0
20294           IRECN(I,2) = 0
20295  200    CONTINUE
20296         RETURN
20297 C  output of statistics
20298       ELSE IF(MSPR.EQ.-2) THEN
20299         IF(IDEB(26).LT.1) RETURN
20300         WRITE(LO,'(/1X,A,/1X,A)')
20301      &    'PHO_HARCOL: sampled color configurations',
20302      &    '----------------------------------------'
20303         WRITE(LO,'(6X,A,15X,A)')
20304      &    'diagram                  color configurations (1-4)','sum'
20305         DO 300 I=1,8
20306           DO 310 K=1,4
20307             ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20308  310      CONTINUE
20309           WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20310  300    CONTINUE
20311         IF(ISWMDL(11).GE.2) THEN
20312           WRITE(LO,'(/6X,A)')
20313      &      'diagram             with   /   without color re-connection'
20314           DO 320 I=1,8
20315             WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20316  320      CONTINUE
20317         ENDIF
20318         RETURN
20319       ENDIF
20320 C
20321 C  gluons: first color positive, quarks second color zero
20322       IF(IP1.EQ.0) THEN
20323         IF(ICA1.LT.0) THEN
20324           I = ICA2
20325           ICA2 = ICA1
20326           ICA1 = I
20327         ENDIF
20328       ELSE
20329         ICA2 = 0
20330       ENDIF
20331       IF(IP2.EQ.0) THEN
20332         IF(ICB1.LT.0) THEN
20333           I = ICB2
20334           ICB2 = ICB1
20335           ICB1 = I
20336         ENDIF
20337       ELSE
20338         ICB2 = 0
20339       ENDIF
20340       IC2 = 0
20341       IC4 = 0
20342 C  debug output
20343       IF(IDEB(26).GE.15)
20344      &  WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20345      &  'PHO_HARCOL: process',MSPR,
20346      &  'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20347 C
20348       IRC = 0
20349       IF(IPAMDL(21).EQ.1) THEN
20350 C
20351 C  soft color re-connection option
20352 C
20353         IF(MSPR.EQ.1) THEN
20354 C  hard g g final state, only g g --> g g
20355           IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20356             IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20357               IC1 = ICA1
20358               IC2 = ICA2
20359               IC3 = ICB1
20360               IC4 = ICB2
20361               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20362               IRC = 1
20363               GOTO 100
20364             ENDIF
20365           ENDIF
20366         ELSE IF(MSPR.EQ.3) THEN
20367 C  hard q g final state
20368           IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20369             IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20370               IC1 = ICA1
20371               IC2 = ICA2
20372               IC3 = ICB1
20373               IC4 = ICB2
20374               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20375               IRC = 1
20376               GOTO 100
20377             ENDIF
20378           ENDIF
20379         ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20380 C  hard q q final state
20381           IF(ICA1.NE.-ICB1) THEN
20382             IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20383               IC1 = ICA1
20384               IC2 = ICA2
20385               IC3 = ICB1
20386               IC4 = ICB2
20387               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20388               IRC = 1
20389               GOTO 100
20390             ENDIF
20391           ENDIF
20392         ENDIF
20393         IRECN(MSPR,2) = IRECN(MSPR,2)+1
20394       ENDIF
20395 C
20396       IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20397 C
20398 C  large Nc limit of all graphs
20399 C
20400         IF(MSPR.EQ.1) THEN
20401 C  g g --> g g
20402           IF(DT_RNDM(V).GT.0.5D0) THEN
20403             IC1 = ICB1
20404             IC2 = ICA2
20405             IC3 = ICA1
20406             IC4 = ICB2
20407             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20408           ELSE
20409             IC1 = ICA1
20410             IC2 = ICB2
20411             IC3 = ICB1
20412             IC4 = ICA2
20413             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20414           ENDIF
20415         ELSE IF(MSPR.EQ.2) THEN
20416 C  q qb --> g g
20417           CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20418           IF(ICA1.LT.0) THEN
20419             IC1 = I1
20420             IC2 = ICA1
20421             IC3 = ICB1
20422             IC4 = I2
20423             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20424           ELSE
20425             IC1 = ICA1
20426             IC2 = I2
20427             IC3 = I1
20428             IC4 = ICB1
20429             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20430           ENDIF
20431         ELSE IF(MSPR.EQ.3) THEN
20432 C  q g --> q g
20433           IF(DT_RNDM(V).LT.0.5D0) THEN
20434             IF(IP1+IP2.GT.0) THEN
20435               IC1 = ICB1
20436               IC2 = ICA2
20437               IC3 = ICA1
20438               IC4 = ICB2
20439             ELSE IF(IP1.LT.0) THEN
20440               IC1 = ICB2
20441               IC3 = ICB1
20442               IC4 = ICA1
20443             ELSE
20444               IC1 = ICA1
20445               IC2 = ICB1
20446               IC3 = ICA2
20447             ENDIF
20448             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20449           ELSE
20450             IF(IP1.GT.0) THEN
20451               CALL PHO_HARCOR(-ICA1,ICB2)
20452               IC1 = ICA1
20453               IC3 = ICB1
20454               IC4 = -ICA1
20455             ELSE IF(IP2.GT.0) THEN
20456               CALL PHO_HARCOR(-ICB1,ICA2)
20457               IC1 = ICA1
20458               IC2 = -ICB1
20459               IC3 = ICB1
20460             ELSE IF(IP1.LT.0) THEN
20461               CALL PHO_HARCOR(-ICA1,ICB1)
20462               IC1 = ICA1
20463               IC3 = -ICA1
20464               IC4 = ICB2
20465             ELSE IF(IP2.LT.0) THEN
20466               CALL PHO_HARCOR(-ICB1,ICA1)
20467               IC1 = -ICB1
20468               IC2 = ICA2
20469               IC3 = ICB1
20470             ENDIF
20471             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20472           ENDIF
20473         ELSE IF(MSPR.EQ.4) THEN
20474 C  g g --> q qb
20475           IC1 = ICA1
20476           IC3 = ICB2
20477           CALL PHO_HARCOR(-ICB1,ICA2)
20478           IF(ICB2.EQ.-ICB1) IC3 = ICA2
20479           IF(IP3*IC1.LT.0) THEN
20480             I = IC1
20481             IC1 = IC3
20482             IC3 = I
20483           ENDIF
20484           ICONF(MSPR,2) = ICONF(MSPR,2)+1
20485         ELSE IF(MSPR.EQ.5) THEN
20486 C  q qb --> q qb
20487           IF(DT_RNDM(V).LT.0.5D0) THEN
20488             IF(ICA1*IP3.LT.0) THEN
20489               IC1 = ICB1
20490               IC3 = ICA1
20491             ELSE
20492               IC1 = ICA1
20493               IC3 = ICB1
20494             ENDIF
20495             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20496           ELSE
20497             IF(ICA1*IP3.LT.0) THEN
20498               IC1 = -ICA1
20499               IC3 = ICA1
20500             ELSE
20501               IC1 = ICA1
20502               IC3 = -ICA1
20503             ENDIF
20504             CALL PHO_HARCOR(-ICA1,ICB1)
20505             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20506           ENDIF
20507         ELSE IF(MSPR.EQ.6) THEN
20508 C  q qb --> qp qbp
20509           IF(ICA1*IP3.LT.0) THEN
20510             IC1 = ICB1
20511             IC3 = ICA1
20512             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20513           ELSE
20514             IC1 = ICA1
20515             IC3 = ICB1
20516             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20517           ENDIF
20518         ELSE IF(MSPR.EQ.7) THEN
20519 C  q q --> q q
20520           IF(DT_RNDM(V).LT.0.5D0) THEN
20521             IC1 = ICA1
20522             IC3 = ICB1
20523             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20524           ELSE
20525             IC1 = ICB1
20526             IC3 = ICA1
20527             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20528           ENDIF
20529         ELSE IF(MSPR.EQ.8) THEN
20530 C  q qp --> q qp
20531           IF(IP1*IP2.GT.0) THEN
20532             IF(IP3.EQ.IP1) THEN
20533               IC1 = ICB1
20534               IC3 = ICA1
20535             ELSE
20536               IC1 = ICA1
20537               IC3 = ICB1
20538             ENDIF
20539             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20540           ELSE
20541             IF(ICA1*IP3.LT.0) THEN
20542               IC1 = -ICA1
20543               IC3 = ICA1
20544             ELSE
20545               IC1 = ICA1
20546               IC3 = -ICA1
20547             ENDIF
20548             CALL PHO_HARCOR(-ICA1,ICB1)
20549             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20550           ENDIF
20551         ELSE
20552 C  unknown process
20553           WRITE(LO,'(/1X,A,I3)')
20554      &      'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20555           CALL PHO_ABORT
20556         ENDIF
20557 C
20558       ELSE
20559 C
20560 C  color flow according to QCD leading order matrix element
20561 C
20562         U = -(1.D0+V)
20563         IF(MSPR.EQ.1) THEN
20564 C  g g --> g g
20565           PC(1) = 1/V**2  +2.D0/V    +3.D0  +2.D0*V    +V**2
20566           PC(2) = 1/U**2  +2.D0/U    +3.D0  +2.D0*U    +U**2
20567           PC(3) = (V/U)**2+2.D0*(V/U)+3.D0  +2.D0*(U/V)+(U/V)**2
20568           XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20569           PCS = 0.D0
20570           DO 110 I=1,3
20571             PCS = PCS+PC(I)
20572             IF(XI.LT.PCS) GOTO 120
20573  110      CONTINUE
20574  120      CONTINUE
20575           IF(I.EQ.1) THEN
20576             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20577             IF(DT_RNDM(V).GT.0.5D0) THEN
20578               IC1 = I1
20579               IC2 = ICA2
20580               IC3 = ICB1
20581               IC4 = I2
20582               CALL PHO_HARCOR(-ICB2,ICA1)
20583               IF(ICB1.EQ.-ICB2) IC3 = ICA1
20584             ELSE
20585               IC1 = ICA1
20586               IC2 = I2
20587               IC3 = I1
20588               IC4 = ICB2
20589               CALL PHO_HARCOR(-ICB1,ICA2)
20590               IF(ICB2.EQ.-ICB1) IC4 = ICA2
20591             ENDIF
20592           ELSE IF(I.EQ.2) THEN
20593             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20594             IF(DT_RNDM(U).GT.0.5D0) THEN
20595               IC1 = ICB1
20596               IC2 = I2
20597               IC3 = I1
20598               IC4 = ICA2
20599               CALL PHO_HARCOR(-ICB2,ICA1)
20600               IF(ICB1.EQ.-ICB2) IC1 = ICA1
20601             ELSE
20602               IC1 = I1
20603               IC2 = ICB2
20604               IC3 = ICA1
20605               IC4 = I2
20606               CALL PHO_HARCOR(-ICB1,ICA2)
20607               IF(ICB2.EQ.-ICB1) IC2 = ICA2
20608             ENDIF
20609           ELSE
20610             IF(DT_RNDM(V).GT.0.5D0) THEN
20611               IC1 = ICB1
20612               IC2 = ICA2
20613               IC3 = ICA1
20614               IC4 = ICB2
20615             ELSE
20616               IC1 = ICA1
20617               IC2 = ICB2
20618               IC3 = ICB1
20619               IC4 = ICA2
20620             ENDIF
20621           ENDIF
20622           ICONF(MSPR,I) = ICONF(MSPR,I)+1
20623         ELSE IF(MSPR.EQ.2) THEN
20624 C  q qb --> g g
20625           PC(1) = U/V-2.D0*U**2
20626           PC(2) = V/U-2.D0*V**2
20627           CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20628           XI = (PC(1)+PC(2))*DT_RNDM(U)
20629           IF(XI.LT.PC(1)) THEN
20630             IF(ICA1.GT.0) THEN
20631               IC1 = ICA1
20632               IC2 = I2
20633               IC3 = I1
20634               IC4 = ICB1
20635               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20636             ELSE
20637               IC1 = I1
20638               IC2 = ICA1
20639               IC3 = ICB1
20640               IC4 = I2
20641               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20642             ENDIF
20643           ELSE
20644             IF(ICA1.GT.0) THEN
20645               IC1 = I1
20646               IC2 = ICB1
20647               IC3 = ICA1
20648               IC4 = I2
20649               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20650             ELSE
20651               IC1 = ICB1
20652               IC2 = I2
20653               IC3 = I1
20654               IC4 = ICA1
20655               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20656             ENDIF
20657           ENDIF
20658         ELSE IF(MSPR.EQ.3) THEN
20659 C  q g --> q g
20660           PC(1) = 2.D0*(U/V)**2-U
20661           PC(2) = 2.D0/V**2-1.D0/U
20662           XI = (PC(1)+PC(2))*DT_RNDM(V)
20663           IF(XI.LT.PC(1)) THEN
20664             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20665             IF(IP1.GT.0) THEN
20666               IC1 = I1
20667               IC3 = ICB1
20668               IC4 = I2
20669               CALL PHO_HARCOR(-ICA1,ICB2)
20670               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20671             ELSE IF(IP1.LT.0) THEN
20672               IC1 = I2
20673               IC3 = I1
20674               IC4 = ICB2
20675               CALL PHO_HARCOR(-ICA1,ICB1)
20676               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20677             ELSE IF(IP2.GT.0) THEN
20678               IC1 = ICA1
20679               IC2 = I2
20680               IC3 = I1
20681               CALL PHO_HARCOR(-ICB1,ICA2)
20682               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20683             ELSE
20684               IC1 = I1
20685               IC2 = ICA2
20686               IC3 = I2
20687               CALL PHO_HARCOR(-ICB1,ICA1)
20688               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20689             ENDIF
20690           ELSE
20691             IF(IP1.GT.0) THEN
20692               IC1 = ICB1
20693               IC3 = ICA1
20694               IC4 = ICB2
20695               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20696             ELSE IF(IP1.LT.0) THEN
20697               IC1 = ICB2
20698               IC3 = ICB1
20699               IC4 = ICA1
20700               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20701             ELSE IF(IP2.GT.0) THEN
20702               IC1 = ICB1
20703               IC2 = ICA2
20704               IC3 = ICA1
20705               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20706             ELSE
20707               IC1 = ICA1
20708               IC2 = ICB1
20709               IC3 = ICA2
20710               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20711             ENDIF
20712           ENDIF
20713         ELSE IF(MSPR.EQ.4) THEN
20714 C  g g --> q qb
20715           PC(1) = U/V-2.D0*U**2
20716           PC(2) = V/U-2.D0*V**2
20717           XI = (PC(1)+PC(2))*DT_RNDM(U)
20718           IF(XI.LT.PC(1)) THEN
20719             IF(IP3.GT.0) THEN
20720               IC1 = ICA1
20721               IC3 = ICB2
20722               CALL PHO_HARCOR(-ICB1,ICA2)
20723               IF(ICB2.EQ.-ICB1) IC3 = ICA2
20724               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20725             ELSE
20726               IC1 = ICA2
20727               IC3 = ICB1
20728               CALL PHO_HARCOR(-ICB2,ICA1)
20729               IF(ICB1.EQ.-ICB2) IC3 = ICA1
20730               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20731             ENDIF
20732           ELSE
20733             IF(IP3.GT.0) THEN
20734               IC1 = ICB1
20735               IC3 = ICA2
20736               CALL PHO_HARCOR(-ICB2,ICA1)
20737               IF(ICB1.EQ.-ICB2) IC1 = ICA1
20738               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20739             ELSE
20740               IC1 = ICB2
20741               IC3 = ICA1
20742               CALL PHO_HARCOR(-ICB1,ICA2)
20743               IF(ICB2.EQ.-ICB1) IC1 = ICA2
20744               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20745             ENDIF
20746           ENDIF
20747         ELSE IF(MSPR.EQ.5) THEN
20748 C  q qb --> q qb
20749           PC(1) = (1.D0+U**2)/V**2
20750           PC(2) = (V**2+U**2)
20751           XI = (PC(1)+PC(2))*DT_RNDM(V)
20752           IF(XI.LT.PC(1)) THEN
20753             CALL PHO_HARCOR(-ICB1,ICA1)
20754             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20755             IF(IP3.GT.0) THEN
20756               IC1 = I1
20757               IC3 = I2
20758               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20759             ELSE
20760               IC1 = I2
20761               IC3 = I1
20762               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20763             ENDIF
20764           ELSE
20765             IF(IP3.GT.0) THEN
20766               IC1 = MAX(ICA1,ICB1)
20767               IC3 = MIN(ICA1,ICB1)
20768               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20769             ELSE
20770               IC1 = MIN(ICA1,ICB1)
20771               IC3 = MAX(ICA1,ICB1)
20772               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20773             ENDIF
20774           ENDIF
20775         ELSE IF(MSPR.EQ.6) THEN
20776 C  q qb --> qp qpb
20777           IF(IP3.GT.0) THEN
20778             IC1 = MAX(ICA1,ICB1)
20779             IC3 = MIN(ICA1,ICB1)
20780             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20781           ELSE
20782             IC1 = MIN(ICA1,ICB1)
20783             IC3 = MAX(ICA1,ICB1)
20784             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20785           ENDIF
20786         ELSE IF(MSPR.EQ.7) THEN
20787 C  q q --> q q
20788           PC(1) = (1.D0+U**2)/V**2
20789           PC(2) = (1.D0+V**2)/U**2
20790           XI = (PC(1)+PC(2))*DT_RNDM(U)
20791           IF(XI.LT.PC(1)) THEN
20792             IC1 = ICB1
20793             IC3 = ICA1
20794             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20795           ELSE
20796             IC1 = ICA1
20797             IC3 = ICB1
20798             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20799           ENDIF
20800         ELSE IF(MSPR.EQ.8) THEN
20801 C  q qp --> q qp
20802           IF(IP1*IP2.LT.0) THEN
20803             CALL PHO_HARCOR(-ICB1,ICA1)
20804             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20805             IF(IP1.GT.0) THEN
20806               IC1 = I1
20807               IC3 = I2
20808               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20809             ELSE
20810               IC1 = I2
20811               IC3 = I1
20812               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20813             ENDIF
20814           ELSE
20815             IC1 = ICB1
20816             IC3 = ICA1
20817             ICONF(MSPR,3) = ICONF(MSPR,3)+1
20818           ENDIF
20819
20820         ELSE IF(MSPR.EQ.10) THEN
20821 C  gam q --> q g
20822           CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
20823           IF(IP3.EQ.0) THEN
20824             CALL PHO_SWAPI(IC1,IC3)
20825             CALL PHO_SWAPI(IC2,IC4)
20826           ENDIF
20827         ELSE IF(MSPR.EQ.11) THEN
20828 C  gam g --> q q
20829           IC1 = ICB1
20830           IC3 = ICB2
20831           IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20832         ELSE IF(MSPR.EQ.12) THEN
20833 C  q gam --> q g
20834           CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
20835           IF(IP3.EQ.0) THEN
20836             CALL PHO_SWAPI(IC1,IC3)
20837             CALL PHO_SWAPI(IC2,IC4)
20838           ENDIF
20839         ELSE IF(MSPR.EQ.13) THEN
20840 C  g gam --> q q
20841           IC1 = ICA1
20842           IC3 = ICA2
20843           IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20844         ELSE IF(MSPR.EQ.14) THEN
20845           IF(ABS(IP3).GT.12) THEN
20846             IC1 = 0
20847             IC3 = 0
20848           ELSE
20849             CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
20850             IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20851           ENDIF
20852         ELSE
20853 C  unknown process
20854           WRITE(LO,'(/1X,A,I3)')
20855      &      'PHO_HARCOL:ERROR:invalid process number',MSPR
20856           CALL PHO_ABORT
20857         ENDIF
20858       ENDIF
20859 C
20860  100  CONTINUE
20861 C  debug output
20862       IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
20863      &    'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
20864 C  color connection?
20865 *     IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
20866 *    &  (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
20867 *    &  .OR.(IC2.EQ.0))) THEN
20868 C  color exchange?
20869 *       IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
20870 *    &     .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
20871 *         IF(IRC.NE.1) THEN
20872 *           WRITE(LO,'(1X,A,I10,I3)')
20873 *    &        'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
20874 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20875 *    &        'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20876 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20877 *    &        'final partons and colors  ',IP3,IC1,IC2,IP4,IC3,IC4
20878 *         ENDIF
20879 *         IRC = 0
20880 *       ENDIF
20881 *     ENDIF
20882 *     IF(IRC.EQ.1) THEN
20883 *           WRITE(LO,'(1X,A,I10,I3)')
20884 *    &        'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
20885 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20886 *    &        'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20887 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20888 *    &        'final partons and colors  ',IP3,IC1,IC2,IP4,IC3,IC4
20889 *     ENDIF
20890 C
20891       ICC1 = IC1
20892       ICC2 = IC2
20893       ICD1 = IC3
20894       ICD2 = IC4
20895
20896       END
20897
20898 *$ CREATE PHO_HARCOR.FOR
20899 *COPY PHO_HARCOR
20900 CDECK  ID>, PHO_HARCOR
20901       SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
20902 C***********************************************************************
20903 C
20904 C     substituite color in /POEVT2/
20905 C
20906 C     input:    ICOLD   old color
20907 C               ICNEW   new color
20908 C
20909 C***********************************************************************
20910       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20911       SAVE
20912
20913 C  input/output channels
20914       INTEGER LI,LO
20915       COMMON /POINOU/ LI,LO
20916 C  standard particle data interface
20917       INTEGER NMXHEP
20918       PARAMETER (NMXHEP=4000)
20919       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
20920       DOUBLE PRECISION PHEP,VHEP
20921       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
20922      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
20923      &                VHEP(4,NMXHEP)
20924 C  extension to standard particle data interface (PHOJET specific)
20925       INTEGER IMPART,IPHIST,ICOLOR
20926       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
20927
20928       DO 100 I=NHEP,3,-1
20929         IF(ISTHEP(I).EQ.-1) THEN
20930           IF(ICOLOR(1,I).EQ.ICOLD) THEN
20931             ICOLOR(1,I) = ICNEW
20932             RETURN
20933           ELSE IF(IDHEP(I).EQ.21) THEN
20934             IF(ICOLOR(2,I).EQ.ICOLD) THEN
20935               ICOLOR(2,I) = ICNEW
20936               RETURN
20937             ENDIF
20938           ENDIF
20939 *       ELSE IF(ISTHEP(I).EQ.20) THEN
20940 *         IF(ICOLOR(1,I).EQ.-ICOLD) THEN
20941 *           WRITE(LO,*) ' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
20942 *           ICOLOR(1,I) = -ICNEW
20943 *           RETURN
20944 *         ELSE IF(IDHEP(I).EQ.21) THEN
20945 *           IF(ICOLOR(2,I).EQ.-ICOLD) THEN
20946 *             WRITE(LO,*) ' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
20947 *             ICOLOR(2,I) = -ICNEW
20948 *             RETURN
20949 *           ENDIF
20950 *         ENDIF
20951         ENDIF
20952  100  CONTINUE
20953       END
20954
20955 *$ CREATE PHO_HARREM.FOR
20956 *COPY PHO_HARREM
20957 CDECK  ID>, PHO_HARREM
20958       SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
20959      &                      IUSED,IREJ)
20960 C***********************************************************************
20961 C
20962 C     sample color structure for initial quark/gluon of hard scattering
20963 C     and write hadron remnant to /POEVT1/
20964 C
20965 C     input:    JM1,2   index of mother particle in POEVT1
20966 C               IGEN    mother particle production process
20967 C               IHPOS   hard pomeron number
20968 C               INDXH   index of hard parton
20969 C                       positive for labels 1
20970 C                       negative for labels 2
20971 C               IVAL     1  hard valence parton
20972 C                        0  hard sea parton connected by color flow with
20973 C                           valence quarks
20974 C                       -1  hard sea parton independent off valence
20975 C                           quarks
20976 C               INDXS   index of soft partons needed
20977 C
20978 C     output:   IC1,IC2 color label of initial parton
20979 C               IUSED   number of soft X values used
20980 C               IREJ    rejection flag
20981 C
20982 C**********************************************************************
20983       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20984       SAVE
20985
20986       PARAMETER ( TINY   =  1.D-10 )
20987
20988 C  input/output channels
20989       INTEGER LI,LO
20990       COMMON /POINOU/ LI,LO
20991 C  event debugging information
20992       INTEGER NMAXD
20993       PARAMETER (NMAXD=100)
20994       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20995      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20996       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20997      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20998 C  model switches and parameters
20999       CHARACTER*8 MDLNA
21000       INTEGER ISWMDL,IPAMDL
21001       DOUBLE PRECISION PARMDL
21002       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21003 C  data of c.m. system of Pomeron / Reggeon exchange
21004       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21005       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21006      &                 SIDP,CODP,SIFP,COFP
21007       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21008      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
21009      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
21010 C  obsolete cut-off information
21011       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21012       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21013 C  light-cone x fractions and c.m. momenta of soft cut string ends
21014       INTEGER MAXSOF
21015       PARAMETER ( MAXSOF = 50 )
21016       INTEGER IJSI2,IJSI1
21017       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21018       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21019      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21020      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
21021 C  hard scattering data
21022       INTEGER MSCAHD
21023       PARAMETER ( MSCAHD = 50 )
21024       INTEGER LSCAHD,LSC1HD,LSIDX,
21025      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21026       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21027       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21028      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21029      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21030      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21031      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21032      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21033      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21034 C  standard particle data interface
21035       INTEGER NMXHEP
21036       PARAMETER (NMXHEP=4000)
21037       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21038       DOUBLE PRECISION PHEP,VHEP
21039       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21040      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21041      &                VHEP(4,NMXHEP)
21042 C  extension to standard particle data interface (PHOJET specific)
21043       INTEGER IMPART,IPHIST,ICOLOR
21044       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21045 C  internal rejection counters
21046       INTEGER NMXJ
21047       PARAMETER (NMXJ=60)
21048       CHARACTER*10 REJTIT
21049       INTEGER IFAIL
21050       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21051
21052       IREJ = 0
21053
21054       INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21055
21056       IF(INDXH.GT.0) THEN
21057         IJH = IPHO_CNV1(NINHD(INDXH,1))
21058       ELSE
21059         IJH = IPHO_CNV1(NINHD(-INDXH,2))
21060       ENDIF
21061 C  direct process (photon or pomeron)
21062       IUSED = 0
21063       IC1   = 0
21064       IC2   = 0
21065       IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21066
21067       IHP = 100*ABS(IHPOS)
21068       IVSW = 1
21069 ***************************************
21070 *     IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21071 ***************************************
21072
21073       IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21074      &  'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21075      &  JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21076
21077 C  quark
21078 C****************************************************************
21079
21080         IF(IJH.NE.21) THEN
21081
21082 C  valence quark engaged in hard scattering
21083           IF(IVAL.EQ.1) THEN
21084             CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21085             IF(IREJ.NE.0) THEN
21086               WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21087      &          'invalid valence flavour requested JM,IFLA',JM1,IJH
21088               return
21089             ENDIF
21090             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21091             IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21092      &         .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21093               I = ICA1
21094               ICA1 = ICB1
21095               ICB1 = I
21096             ENDIF
21097 C  remnant of hadron
21098             IF(INDXH.GT.0) THEN
21099               P1 = PSOFT1(1,INDXS)
21100               P2 = PSOFT1(2,INDXS)
21101               P3 = PSOFT1(3,INDXS)
21102               P4 = PSOFT1(4,INDXS)
21103               IJSI1(INDXS) = IREM
21104             ELSE
21105               P1 = PSOFT2(1,INDXS)
21106               P2 = PSOFT2(2,INDXS)
21107               P3 = PSOFT2(3,INDXS)
21108               P4 = PSOFT2(4,INDXS)
21109               IJSI2(INDXS) = IREM
21110             ENDIF
21111 C  registration
21112             CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21113      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21114             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21115      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21116      &        IREM,IPOS,SIGN(INDXS,INDXH)
21117             IUSED = 1
21118
21119 C  sea quark engaged in hard scattering, valence quarks treated
21120           ELSE IF(IVAL.EQ.0) THEN
21121             IF(INDXH.GT.0) THEN
21122               E1 = PSOFT1(4,INDXS)
21123               E2 = PSOFT1(4,INDXS+1)
21124             ELSE
21125               E1 = PSOFT2(4,INDXS)
21126               E2 = PSOFT2(4,INDXS+1)
21127             ENDIF
21128             CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21129             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21130             IF(DT_RNDM(P1).LT.0.5D0) THEN
21131               CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21132             ELSE
21133               CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21134             ENDIF
21135             IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21136      &         .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21137               I = ICA1
21138               ICA1 = ICB1
21139               ICB1 = I
21140             ENDIF
21141             IF(INDXH.GT.0) THEN
21142               P1 = PSOFT1(1,INDXS)
21143               P2 = PSOFT1(2,INDXS)
21144               P3 = PSOFT1(3,INDXS)
21145               P4 = PSOFT1(4,INDXS)
21146               IJSI1(INDXS) = IVFL1
21147             ELSE
21148               P1 = PSOFT2(1,INDXS)
21149               P2 = PSOFT2(2,INDXS)
21150               P3 = PSOFT2(3,INDXS)
21151               P4 = PSOFT2(4,INDXS)
21152               IJSI2(INDXS) = IVFL1
21153             ENDIF
21154 C  registration
21155             CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21156      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21157             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21158      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21159      &        IVFL1,IPOS,SIGN(INDXS,INDXH)
21160 C
21161             IF(INDXH.GT.0) THEN
21162               P1 = PSOFT1(1,INDXS+1)
21163               P2 = PSOFT1(2,INDXS+1)
21164               P3 = PSOFT1(3,INDXS+1)
21165               P4 = PSOFT1(4,INDXS+1)
21166               IJSI1(INDXS+1) = IVFL2
21167             ELSE
21168               P1 = PSOFT2(1,INDXS+1)
21169               P2 = PSOFT2(2,INDXS+1)
21170               P3 = PSOFT2(3,INDXS+1)
21171               P4 = PSOFT2(4,INDXS+1)
21172               IJSI2(INDXS+1) = IVFL2
21173             ENDIF
21174 C  registration
21175             CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21176      &                  IHP,IGEN,ICB1,IVSW,IPOS,1)
21177             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21178      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21179      &        IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21180 C
21181             IF(IJH.LT.0) THEN
21182               ICB1 = ICC2
21183               ICA1 = ICC1
21184             ELSE
21185               ICB1 = ICC1
21186               ICA1 = ICC2
21187             ENDIF
21188             IF(INDXH.GT.0) THEN
21189               P1 = PSOFT1(1,INDXS+2)
21190               P2 = PSOFT1(2,INDXS+2)
21191               P3 = PSOFT1(3,INDXS+2)
21192               P4 = PSOFT1(4,INDXS+2)
21193               IJSI1(INDXS+2) = -IJH
21194             ELSE
21195               P1 = PSOFT2(1,INDXS+2)
21196               P2 = PSOFT2(2,INDXS+2)
21197               P3 = PSOFT2(3,INDXS+2)
21198               P4 = PSOFT2(4,INDXS+2)
21199               IJSI2(INDXS+2) = -IJH
21200             ENDIF
21201 C  registration
21202             CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21203      &                      IHP,IGEN,ICA1,0,IPOS,1)
21204             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21205      &        'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21206      &        -IJH,IPOS,SIGN(INDXS+2,INDXH)
21207             IUSED = 3
21208 C
21209 C  sea quark engaged in hard scattering, valences treated separately
21210           ELSE IF(IVAL.EQ.-1) THEN
21211             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21212             IF(IJH.GT.0) THEN
21213               ICC1 = ICB1
21214               ICB1 = ICA1
21215               ICA1 = ICC1
21216             ENDIF
21217             IF(INDXH.GT.0) THEN
21218               P1 = PSOFT1(1,INDXS)
21219               P2 = PSOFT1(2,INDXS)
21220               P3 = PSOFT1(3,INDXS)
21221               P4 = PSOFT1(4,INDXS)
21222               IJSI1(INDXS) = -IJH
21223             ELSE
21224               P1 = PSOFT2(1,INDXS)
21225               P2 = PSOFT2(2,INDXS)
21226               P3 = PSOFT2(3,INDXS)
21227               P4 = PSOFT2(4,INDXS)
21228               IJSI2(INDXS) = -IJH
21229             ENDIF
21230 C  registration
21231             CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21232      &                      IHP,IGEN,ICA1,0,IPOS,1)
21233             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21234      &        'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21235      &        -IJH,IPOS,SIGN(INDXS,INDXH)
21236             IUSED = 1
21237           ELSE
21238             WRITE(LO,'(1X,A,2I5)')
21239      &        'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21240      &        IVAL,IJH
21241             CALL PHO_ABORT
21242           ENDIF
21243 C
21244           IC1 = ICB1
21245           IC2 = 0
21246 C
21247 C  gluon
21248 C****************************************************************
21249 C
21250 C  gluon from valence quarks
21251         ELSE
21252           IF(IVAL.EQ.1) THEN
21253 C  purely gluonic pomeron remnant
21254             IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21255               IF(INDXH.GT.0) THEN
21256                 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21257                 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21258                 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21259                 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21260                 IJSI1(INDXS) = 0
21261               ELSE
21262                 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21263                 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21264                 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21265                 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21266                 IJSI2(INDXS) = 0
21267               ENDIF
21268               IFL1 = 21
21269               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21270               IF(DT_RNDM(P2).LT.0.5D0) THEN
21271                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21272               ELSE
21273                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21274               ENDIF
21275 C  registration
21276               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21277      &                        IHP,IGEN,ICA1,ICB1,IPOS,1)
21278               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21279      &          'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21280      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21281               IUSED = 2
21282 C  valence quark remnant
21283             ELSE
21284               IF(INDXH.GT.0) THEN
21285                 E1 = PSOFT1(4,INDXS)
21286                 E2 = PSOFT1(4,INDXS+1)
21287               ELSE
21288                 E1 = PSOFT2(4,INDXS)
21289                 E2 = PSOFT2(4,INDXS+1)
21290               ENDIF
21291               CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21292               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21293               IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21294      &           .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21295                 I = ICA1
21296                 ICA1 = ICB1
21297                 ICB1 = I
21298               ENDIF
21299               IF(DT_RNDM(P2).LT.0.5D0) THEN
21300                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21301               ELSE
21302                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21303               ENDIF
21304 C  remnant of hadron
21305               IF(INDXH.GT.0) THEN
21306                 P1 = PSOFT1(1,INDXS)
21307                 P2 = PSOFT1(2,INDXS)
21308                 P3 = PSOFT1(3,INDXS)
21309                 P4 = PSOFT1(4,INDXS)
21310                 IJSI1(INDXS) = IFL1
21311               ELSE
21312                 P1 = PSOFT2(1,INDXS)
21313                 P2 = PSOFT2(2,INDXS)
21314                 P3 = PSOFT2(3,INDXS)
21315                 P4 = PSOFT2(4,INDXS)
21316                 IJSI2(INDXS) = IFL1
21317               ENDIF
21318 C  registration
21319               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21320      &                        IHP,IGEN,ICA1,IVSW,IPOS,1)
21321               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21322      &          'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21323      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21324 C
21325               IF(INDXH.GT.0) THEN
21326                 P1 = PSOFT1(1,INDXS+1)
21327                 P2 = PSOFT1(2,INDXS+1)
21328                 P3 = PSOFT1(3,INDXS+1)
21329                 P4 = PSOFT1(4,INDXS+1)
21330                 IJSI1(INDXS+1) = IFL2
21331               ELSE
21332                 P1 = PSOFT2(1,INDXS+1)
21333                 P2 = PSOFT2(2,INDXS+1)
21334                 P3 = PSOFT2(3,INDXS+1)
21335                 P4 = PSOFT2(4,INDXS+1)
21336                 IJSI2(INDXS+1) = IFL2
21337               ENDIF
21338 C  registration
21339               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21340      &                        IHP,IGEN,ICB1,IVSW,IPOS,1)
21341               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21342      &          'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21343      &          IFL2,IPOS,SIGN(INDXS+1,INDXH)
21344               IUSED = 2
21345             ENDIF
21346 C
21347 C  gluon from sea quarks connected with valence quarks
21348           ELSE IF(IVAL.EQ.0) THEN
21349             IF(INDXH.GT.0) THEN
21350               E1 = PSOFT1(4,INDXS)
21351               E2 = PSOFT1(4,INDXS+1)
21352             ELSE
21353               E1 = PSOFT2(4,INDXS)
21354               E2 = PSOFT2(4,INDXS+1)
21355             ENDIF
21356             CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21357             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21358             IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21359      &         .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21360               I = ICA1
21361               ICA1 = ICB1
21362               ICB1 = I
21363             ENDIF
21364             IF(DT_RNDM(P3).LT.0.5D0) THEN
21365               CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21366             ELSE
21367               CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21368             ENDIF
21369 C  remnant of hadron
21370             IF(INDXH.GT.0) THEN
21371               P1 = PSOFT1(1,INDXS)
21372               P2 = PSOFT1(2,INDXS)
21373               P3 = PSOFT1(3,INDXS)
21374               P4 = PSOFT1(4,INDXS)
21375               IJSI1(INDXS) = IFL1
21376             ELSE
21377               P1 = PSOFT2(1,INDXS)
21378               P2 = PSOFT2(2,INDXS)
21379               P3 = PSOFT2(3,INDXS)
21380               P4 = PSOFT2(4,INDXS)
21381               IJSI2(INDXS) = IFL1
21382             ENDIF
21383 C  registration
21384             CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21385      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21386             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21387      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21388      &        IFL1,IPOS,SIGN(INDXS,INDXH)
21389 C
21390             IF(INDXH.GT.0) THEN
21391               P1 = PSOFT1(1,INDXS+1)
21392               P2 = PSOFT1(2,INDXS+1)
21393               P3 = PSOFT1(3,INDXS+1)
21394               P4 = PSOFT1(4,INDXS+1)
21395               IJSI1(INDXS+1) = IFL2
21396             ELSE
21397               P1 = PSOFT2(1,INDXS+1)
21398               P2 = PSOFT2(2,INDXS+1)
21399               P3 = PSOFT2(3,INDXS+1)
21400               P4 = PSOFT2(4,INDXS+1)
21401               IJSI2(INDXS+1) = IFL2
21402             ENDIF
21403 C  registration
21404             CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21405      &                      IHP,IGEN,ICB1,IVSW,IPOS,1)
21406             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21407      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21408      &        IFL2,IPOS,SIGN(INDXS+1,INDXH)
21409             IF(IPAMDL(18).EQ.0)  THEN
21410 C  sea quark pair
21411               CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21412               IF(ICC1.GT.0) THEN
21413                 IFL1 = ABS(IFL1)
21414                 IFL2 = -IFL1
21415               ELSE
21416                 IFL1 = -ABS(IFL1)
21417                 IFL2 = -IFL1
21418               ENDIF
21419               IF(DT_RNDM(P4).LT.0.5D0) THEN
21420                 ICB1 = ICC2
21421                 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21422               ELSE
21423                 ICA1 = ICC1
21424                 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21425               ENDIF
21426               IF(INDXH.GT.0) THEN
21427                 P1 = PSOFT1(1,INDXS+2)
21428                 P2 = PSOFT1(2,INDXS+2)
21429                 P3 = PSOFT1(3,INDXS+2)
21430                 P4 = PSOFT1(4,INDXS+2)
21431                 IJSI1(INDXS+2) = IFL1
21432               ELSE
21433                 P1 = PSOFT2(1,INDXS+2)
21434                 P2 = PSOFT2(2,INDXS+2)
21435                 P3 = PSOFT2(3,INDXS+2)
21436                 P4 = PSOFT2(4,INDXS+2)
21437                 IJSI2(INDXS+2) = IFL1
21438               ENDIF
21439 C  registration
21440               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21441      &                        IHP,IGEN,ICA1,0,IPOS,1)
21442               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21443      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21444      &          IFL1,IPOS,SIGN(INDXS+2,INDXH)
21445 C
21446               IF(INDXH.GT.0) THEN
21447                 P1 = PSOFT1(1,INDXS+3)
21448                 P2 = PSOFT1(2,INDXS+3)
21449                 P3 = PSOFT1(3,INDXS+3)
21450                 P4 = PSOFT1(4,INDXS+3)
21451                 IJSI1(INDXS+3) = IFL2
21452               ELSE
21453                 P1 = PSOFT2(1,INDXS+3)
21454                 P2 = PSOFT2(2,INDXS+3)
21455                 P3 = PSOFT2(3,INDXS+3)
21456                 P4 = PSOFT2(4,INDXS+3)
21457                 IJSI2(INDXS+3) = IFL2
21458               ENDIF
21459 C  registration
21460               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21461      &                        IHP,IGEN,ICB1,0,IPOS,1)
21462               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21463      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21464      &          IFL2,IPOS,SIGN(INDXS+3,INDXH)
21465               IUSED = 4
21466             ELSE
21467               IUSED = 2
21468             ENDIF
21469 C
21470 C  gluon from independent sea quarks
21471           ELSE IF(IVAL.EQ.-1) THEN
21472             IF(IPAMDL(18).EQ.0) THEN
21473               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21474               CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21475               IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21476      &           .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21477                 I = ICA1
21478                 ICA1 = ICB1
21479                 ICB1 = I
21480               ENDIF
21481               IF(DT_RNDM(P1).LT.0.5D0) THEN
21482                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21483               ELSE
21484                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21485               ENDIF
21486 C  remainder of hadron
21487               IF(INDXH.GT.0) THEN
21488                 P1 = PSOFT1(1,INDXS)
21489                 P2 = PSOFT1(2,INDXS)
21490                 P3 = PSOFT1(3,INDXS)
21491                 P4 = PSOFT1(4,INDXS)
21492                 IJSI1(INDXS) = IFL1
21493               ELSE
21494                 P1 = PSOFT2(1,INDXS)
21495                 P2 = PSOFT2(2,INDXS)
21496                 P3 = PSOFT2(3,INDXS)
21497                 P4 = PSOFT2(4,INDXS)
21498                 IJSI2(INDXS) = IFL1
21499               ENDIF
21500 C  registration
21501               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21502      &                        IHP,IGEN,ICA1,ICA2,IPOS,1)
21503               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21504      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21505      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21506 C  remnant of sea
21507               IF(INDXH.GT.0) THEN
21508                 P1 = PSOFT1(1,INDXS-1)
21509                 P2 = PSOFT1(2,INDXS-1)
21510                 P3 = PSOFT1(3,INDXS-1)
21511                 P4 = PSOFT1(4,INDXS-1)
21512                 IJSI1(INDXS-1) = IFL2
21513               ELSE
21514                 P1 = PSOFT2(1,INDXS-1)
21515                 P2 = PSOFT2(2,INDXS-1)
21516                 P3 = PSOFT2(3,INDXS-1)
21517                 P4 = PSOFT2(4,INDXS-1)
21518                 IJSI2(INDXS-1) = IFL2
21519               ENDIF
21520 C  registration
21521               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21522      &                        IHP,IGEN,ICB1,ICB2,IPOS,1)
21523               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21524      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21525      &          IFL2,IPOS,SIGN(INDXS-1,INDXH)
21526               IUSED = 2
21527             ELSE
21528               CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21529               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21530      &          'PHO_HARREM: no spectator added:(INDXS)',
21531      &          SIGN(INDXS,INDXH)
21532               IUSED = 0
21533             ENDIF
21534 C
21535           ELSE
21536             WRITE(LO,'(1X,A,2I5)')
21537      &        'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21538      &        IVAL,IJH
21539             CALL PHO_ABORT
21540           ENDIF
21541           IC1 = ICC1
21542           IC2 = ICC2
21543         ENDIF
21544       END
21545
21546 *$ CREATE PHO_HARDIR.FOR
21547 *COPY PHO_HARDIR
21548 CDECK  ID>, PHO_HARDIR
21549       SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21550      &                      IREJ)
21551 C**********************************************************************
21552 C
21553 C     parton orientated formulation of direct scattering processes
21554 C
21555 C     input:
21556 C
21557 C     output:   II        particle combination (1..4)
21558 C               IVAL1,2   0 no valence quarks engaged
21559 C                         1 valence quarks engaged
21560 C               MSPAR1,2  number of realized soft partons
21561 C               MHPAR1,2  number of realized hard partons
21562 C               IREJ      1 failure
21563 C                         0 success
21564 C
21565 C**********************************************************************
21566       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21567       SAVE
21568
21569 C  input/output channels
21570       INTEGER LI,LO
21571       COMMON /POINOU/ LI,LO
21572 C  event debugging information
21573       INTEGER NMAXD
21574       PARAMETER (NMAXD=100)
21575       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21576      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21577       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21578      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21579 C  model switches and parameters
21580       CHARACTER*8 MDLNA
21581       INTEGER ISWMDL,IPAMDL
21582       DOUBLE PRECISION PARMDL
21583       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21584 C  hard scattering parameters used for most recent hard interaction
21585       INTEGER NFbeta,NF
21586       DOUBLE PRECISION ALQCD2,BQCD
21587       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21588 C  data of c.m. system of Pomeron / Reggeon exchange
21589       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21590       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21591      &                 SIDP,CODP,SIFP,COFP
21592       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21593      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
21594      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
21595 C  obsolete cut-off information
21596       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21597       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21598 C  hard cross sections and MC selection weights
21599       INTEGER Max_pro_2
21600       PARAMETER ( Max_pro_2 = 16 )
21601       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21602      &  MH_acc_1,MH_acc_2
21603       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21604       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21605      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21606      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21607      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21608      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21609 C  data on most recent hard scattering
21610       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21611       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21612      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21613      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21614       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21615      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21616      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21617      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21618      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21619 C  light-cone x fractions and c.m. momenta of soft cut string ends
21620       INTEGER MAXSOF
21621       PARAMETER ( MAXSOF = 50 )
21622       INTEGER IJSI2,IJSI1
21623       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21624       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21625      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21626      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
21627 C  hard scattering data
21628       INTEGER MSCAHD
21629       PARAMETER ( MSCAHD = 50 )
21630       INTEGER LSCAHD,LSC1HD,LSIDX,
21631      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21632       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21633       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21634      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21635      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21636      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21637      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21638      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21639      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21640 C  internal rejection counters
21641       INTEGER NMXJ
21642       PARAMETER (NMXJ=60)
21643       CHARACTER*10 REJTIT
21644       INTEGER IFAIL
21645       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21646
21647       DIMENSION P1(4),P2(4),PD1(-6:6)
21648
21649       PARAMETER ( TINY   =  1.D-10 )
21650
21651       ITRY  = 0
21652       NTRY  = 10
21653       LSC1HD = 0
21654       LSIDX(1) = 1
21655
21656 C  check phase space
21657       IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21658         IFAIL(18) = IFAIL(18)+1
21659         IREJ = 50
21660         RETURN
21661       ENDIF
21662
21663       AS     = (PARMDL(160+II)/ECMP)**2
21664       AH     = (2.D0*PTWANT/ECMP)**2
21665
21666       ALNS   = LOG(AS)
21667       ALNH   = LOG(AH)
21668
21669       XMAX   = MAX(TINY,1.D0-AS)
21670       Z1MAX  = LOG(XMAX)
21671       Z1DIF  = Z1MAX-ALNH
21672 C
21673 C  main loop to select hard and soft parton kinematics
21674 C -----------------------------------------------------
21675  120  CONTINUE
21676         IREJ = 0
21677         ITRY   = ITRY+1
21678         LSC1HD = LSC1HD+1
21679         IF(ITRY.GT.1) THEN
21680           IFAIL(17) = IFAIL(17)+1
21681           IF(ITRY.GE.NTRY) THEN
21682             IREJ = 1
21683             GOTO 450
21684           ENDIF
21685         ENDIF
21686         LINE   = 0
21687         LSCAHD = 0
21688         XSS1   = 0.D0
21689         XSS2   = 0.D0
21690         MSPAR1 = 0
21691         MSPAR2 = 0
21692
21693 C  select hard V,X
21694         CALL PHO_HARSCA(1,II)
21695         XSS1   = XSS1+X1
21696         XSS2   = XSS2+X2
21697 C  debug output
21698         IF(IDEB(25).GE.20) THEN
21699           WRITE(LO,'(1X,A,2E12.4,2I5)')
21700      &      'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21701      &      AS,XMAX,MSPR,ITRY
21702           WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2  SUM X1,2',
21703      &      X1,X2,XSS1,XSS2
21704         ENDIF
21705
21706       IF(MSPR.LE.11) THEN
21707         IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21708       ELSE IF(MSPR.LE.13) THEN
21709         IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21710       ENDIF
21711
21712 C  fill /POHSLT/
21713       LSCAHD     = 1
21714       LSIDX(1)   = 1
21715       XHD(1,1)   = X1
21716       XHD(1,2)   = X2
21717       X0HD(1,1)  = X1
21718       X0HD(1,2)  = X2
21719       VHD(1)     = V
21720       ETAHD(1,1) = ETAC
21721       ETAHD(1,2) = ETAD
21722       PTHD(1)    = PT
21723       Q2SCA(1,1) = QQPD
21724       Q2SCA(1,2) = QQPD
21725       NPROHD(1)  = MSPR
21726       NBRAHD(1,1)= IDPDG1
21727       NBRAHD(1,2)= IDPDG2
21728       DO 45 I=1,4
21729         PPH(I,1)   = PHI1(I)
21730         PPH(I,2)   = PHI2(I)
21731         PPH(4+I,1) = PHO1(I)
21732         PPH(4+I,2) = PHO2(I)
21733  45   CONTINUE
21734 C  valence quarks
21735       IVAL1 = IV1
21736       IVAL2 = IV2
21737       PDFVA(1,1) = 0.D0
21738       PDFVA(1,2) = 0.D0
21739 C  parton flavours
21740       IF(MSPR.LE.11) THEN
21741         NINHD(1,1) = IDPDG1
21742         NINHD(1,2) = IB
21743         PDFVA(1,2) = PDF2(IB)
21744         KHDIR = 1
21745       ELSE IF(MSPR.LE.13) THEN
21746         NINHD(1,1) = IA
21747         PDFVA(1,1) = PDF1(IA)
21748         NINHD(1,2) = IDPDG2
21749         KHDIR = 2
21750       ELSE
21751         NINHD(1,1) = IDPDG1
21752         NINHD(1,2) = IDPDG2
21753         KHDIR = 3
21754       ENDIF
21755       N0INHD(1,1) = NINHD(1,1)
21756       N0INHD(1,2) = NINHD(1,2)
21757       N0IVAL(1,1) = IVAL1
21758       N0IVAL(1,2) = IVAL2
21759       NOUTHD(1,1) = IC
21760       NOUTHD(1,2) = ID
21761
21762 C  reweight according to photon virtuality
21763       IF(MSPR.NE.14) THEN
21764         IF(IPAMDL(115).GE.1) THEN
21765           WGX = 1.D0
21766           IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21767             QQPD = Q2SCA(1,2)
21768             IF(IPAMDL(115).EQ.1) THEN
21769               IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21770                 WGX = 0.D0
21771               ELSE
21772                 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21773      &               /LOG(QQPD/PARMDL(144))
21774               ENDIF
21775               IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21776             ELSE IF(IPAMDL(115).EQ.2) THEN
21777               CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21778               WGX = PD1(IB)/PDFVA(1,2)
21779             ENDIF
21780           ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21781      &            .AND.(IDPDG1.EQ.22)) THEN
21782             QQPD = Q2SCA(1,1)
21783             IF(IPAMDL(115).EQ.1) THEN
21784               IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
21785                 WGX = 0.D0
21786               ELSE
21787                 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
21788      &               /LOG(QQPD/PARMDL(144))
21789               ENDIF
21790               IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
21791             ELSE IF(IPAMDL(115).EQ.2) THEN
21792               CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
21793               WGX = PD1(IA)/PDFVA(1,1)
21794             ENDIF
21795           ENDIF
21796
21797           IF(IDEB(25).GE.25)
21798      &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21799      &        're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21800      &        KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21801
21802           IF(WGX.LT.DT_RNDM(WGX)) THEN
21803             IREJ = 50
21804             RETURN
21805           ENDIF
21806
21807           IF(WGX.GT.1.01D0)
21808      &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21809      &        're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21810      &        KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21811
21812         ENDIF
21813       ENDIF
21814
21815 C  generate ISR
21816       IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
21817         IF(IPAMDL(109).EQ.1) THEN
21818           Q2H = PARMDL(93)*PT**2
21819         ELSE
21820           Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
21821         ENDIF
21822         XHMAX1 =  1.D0 - XSS1 - AS + XHD(1,1)
21823         XHMAX2 =  1.D0 - XSS2 - AS + XHD(1,2)
21824         DO 42 J=1,4
21825           P1(J) = PPH(4+J,1)
21826           P2(J) = PPH(4+J,2)
21827  42     CONTINUE
21828         CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
21829      &    N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
21830      &    XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
21831         XSS1 = XSS1+XISR1-XHD(1,1)
21832         XSS2 = XSS2+XISR2-XHD(1,2)
21833         NINHD(1,1) = IFL1
21834         NINHD(1,2) = IFL2
21835         XHD(1,1) = XISR1
21836         XHD(1,2) = XISR2
21837       ELSE
21838         IFL1 = NINHD(1,1)
21839         IFL2 = NINHD(1,2)
21840       ENDIF
21841       NIVAL(1,1) = IVAL1
21842       NIVAL(1,2) = IVAL2
21843
21844 C  add photon/hadron remnant
21845
21846 C  incoming gluon
21847       IF(IFL2.EQ.0) THEN
21848         XMAXX    = 1.D0 - XSS2 - AS
21849         XMAXH    = MIN(XMAXX,PARMDL(44))
21850         CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21851         IVAL2 = 1
21852         MSPAR1 = 0
21853         MSPAR2 = 2
21854         MHPAR1 = 1
21855         MHPAR2 = 1
21856       ELSE IF(IFL1.EQ.0) THEN
21857         XMAXX    = 1.D0 - XSS1 - AS
21858         XMAXH    = MIN(XMAXX,PARMDL(44))
21859         CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21860         IVAL1 = 1
21861         MSPAR1 = 2
21862         MSPAR2 = 0
21863         MHPAR1 = 1
21864         MHPAR2 = 1
21865
21866 C  incoming quark
21867       ELSE IF(ABS(IFL2).LE.12) THEN
21868         IF(IVAL2.EQ.1) THEN
21869           XS2(1) = 1.D0 - XSS2
21870           MSPAR1 = 0
21871           MSPAR2 = 1
21872           MHPAR1 = 1
21873           MHPAR2 = 1
21874         ELSE
21875           XMAXX    = 1.D0 - XSS2 - AS
21876           XMAXH    = MIN(XMAXX,PARMDL(44))
21877           CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21878           MSPAR1 = 0
21879           MSPAR2 = 3
21880           MHPAR1 = 1
21881           MHPAR2 = 1
21882         ENDIF
21883       ELSE IF(ABS(IFL1).LE.12) THEN
21884         IF(IVAL1.EQ.1) THEN
21885           XS1(1) = 1.D0 - XSS1
21886           MSPAR1 = 1
21887           MSPAR2 = 0
21888           MHPAR1 = 1
21889           MHPAR2 = 1
21890         ELSE
21891           XMAXX    = 1.D0 - XSS1 - AS
21892           XMAXH    = MIN(XMAXX,PARMDL(44))
21893           CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21894           MSPAR1 = 3
21895           MSPAR2 = 0
21896           MHPAR1 = 1
21897           MHPAR2 = 1
21898         ENDIF
21899
21900 C  double direct process
21901       ELSE IF(MSPR.EQ.14) THEN
21902         MSPAR1 = 0
21903         MSPAR2 = 0
21904         MHPAR1 = 1
21905         MHPAR2 = 1
21906
21907 C  unknown process
21908       ELSE
21909         WRITE(LO,'(/1X,A,I3/)')
21910      &    'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
21911         CALL PHO_ABORT
21912       ENDIF
21913
21914       IF(IREJ.NE.0) THEN
21915         IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
21916      &    'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
21917         GOTO 120
21918       ENDIF
21919
21920 C  soft particle momenta
21921       IF(MSPAR1.GT.0) THEN
21922         DO 50 I=1,MSPAR1
21923           PSOFT1(1,I) = 0.D0
21924           PSOFT1(2,I) = 0.D0
21925           PSOFT1(3,I) = XS1(I)*ECMP/2.D0
21926           PSOFT1(4,I) = XS1(I)*ECMP/2.D0
21927  50     CONTINUE
21928       ENDIF
21929       IF(MSPAR2.GT.0) THEN
21930         DO 55 I=1,MSPAR2
21931           PSOFT2(1,I) = 0.D0
21932           PSOFT2(2,I) = 0.D0
21933           PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
21934           PSOFT2(4,I) = XS2(I)*ECMP/2.D0
21935  55     CONTINUE
21936       ENDIF
21937 C  process counting
21938       MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
21939       KSOFT = MAX(MSPAR1,MSPAR2)
21940       KHARD = MAX(MHPAR1,MHPAR2)
21941 C  debug output
21942       IF(IDEB(25).GE.10) THEN
21943         WRITE(LO,'(/1X,A,2I3,3I5)')
21944      &    'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
21945      &     IVAL1,IVAL2,MSPR,ITRY,NTRY
21946         IF(MSPAR1.GT.0) THEN
21947           WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
21948           DO 105 I=1,MSPAR1
21949             WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
21950  105      CONTINUE
21951         ENDIF
21952         IF(MSPAR2.GT.0) THEN
21953           WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
21954           DO 106 I=1,MSPAR2
21955             WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
21956  106      CONTINUE
21957         ENDIF
21958         WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
21959         WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
21960         WRITE(LO,'(5X,A,I4)') 'fin.hard momenta  particle 1:',MHPAR1
21961         WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
21962         WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
21963         WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
21964         WRITE(LO,'(5X,A,I4)') 'fin.hard momenta  particle 2:',MHPAR2
21965         WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
21966       ENDIF
21967       RETURN
21968
21969  450  CONTINUE
21970       IFAIL(16) = IFAIL(16)+1
21971       IF(IDEB(25).GE.2) THEN
21972         WRITE(LO,'(1X,A,3I5)')
21973      &    'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
21974        WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
21975        IF(IDEB(25).GE.5) THEN
21976          CALL PHO_PREVNT(0)
21977        ELSE
21978          CALL PHO_PREVNT(-1)
21979        ENDIF
21980       ENDIF
21981
21982       END
21983
21984 *$ CREATE PHO_POMSCA.FOR
21985 *COPY PHO_POMSCA
21986 CDECK  ID>, PHO_POMSCA
21987       SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
21988      &                     MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
21989 C**********************************************************************
21990 C
21991 C     parton orientated formulation of soft and hard inelastic events
21992 C
21993 C
21994 C     input:    II        particle combiantion (1..4)
21995 C               MSPOM     number of soft pomerons
21996 C               MHPOM     number of semihard pomerons
21997 C               MSREG     number of soft reggeons
21998 C
21999 C     output:   IVAL1,2   0 no valence quark engaged
22000 C                         otherwise:  position of valence quark engaged
22001 C                         neg.number: gluon connected to valence quark
22002 C                                     by color flow
22003 C               MSPAR1,2  number of realized soft partons
22004 C               MHPAR1,2  number of realized hard partons
22005 C               IREJ      1 failure
22006 C                         0 success
22007 C
22008 C**********************************************************************
22009       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22010       SAVE
22011
22012       PARAMETER (TINY   =  1.D-30 )
22013
22014 C  input/output channels
22015       INTEGER LI,LO
22016       COMMON /POINOU/ LI,LO
22017 C  event debugging information
22018       INTEGER NMAXD
22019       PARAMETER (NMAXD=100)
22020       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22021      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22022       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22023      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22024 C  model switches and parameters
22025       CHARACTER*8 MDLNA
22026       INTEGER ISWMDL,IPAMDL
22027       DOUBLE PRECISION PARMDL
22028       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22029 C  general process information
22030       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22031       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22032 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
22033       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22034       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22035       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22036      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22037 C  event weights and generated cross section
22038       INTEGER IPOWGC,ISWCUT,IVWGHT
22039       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22040       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22041      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22042 C  hard cross sections and MC selection weights
22043       INTEGER Max_pro_2
22044       PARAMETER ( Max_pro_2 = 16 )
22045       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22046      &  MH_acc_1,MH_acc_2
22047       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22048       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22049      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22050      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22051      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22052      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22053 C  hard scattering parameters used for most recent hard interaction
22054       INTEGER NFbeta,NF
22055       DOUBLE PRECISION ALQCD2,BQCD
22056       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22057 C  data of c.m. system of Pomeron / Reggeon exchange
22058       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22059       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22060      &                 SIDP,CODP,SIFP,COFP
22061       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22062      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
22063      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
22064 C  obsolete cut-off information
22065       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22066       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22067 C  some hadron information, will be deleted in future versions
22068       INTEGER NFS
22069       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22070       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22071 C  data on most recent hard scattering
22072       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22073       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22074      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22075      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22076       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22077      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22078      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22079      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22080      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22081 C  light-cone x fractions and c.m. momenta of soft cut string ends
22082       INTEGER MAXSOF
22083       PARAMETER ( MAXSOF = 50 )
22084       INTEGER IJSI2,IJSI1
22085       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22086       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22087      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22088      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
22089 C  hard scattering data
22090       INTEGER MSCAHD
22091       PARAMETER ( MSCAHD = 50 )
22092       INTEGER LSCAHD,LSC1HD,LSIDX,
22093      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22094       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22095       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22096      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22097      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22098      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22099      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22100      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22101      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22102 C  table of particle indices for recursive PHOJET calls
22103       INTEGER MAXIPX
22104       PARAMETER ( MAXIPX = 100 )
22105       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22106       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22107      &                IPOIX1,IPOIX2,IPOIX3
22108 C  internal rejection counters
22109       INTEGER NMXJ
22110       PARAMETER (NMXJ=60)
22111       CHARACTER*10 REJTIT
22112       INTEGER IFAIL
22113       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22114
22115       DIMENSION P1(4),P2(4),PD1(-6:6)
22116
22117       IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22118      &  'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22119
22120       ITRY  = 0
22121       NTRY  = 10
22122       IREJ  = 0
22123       INMAX = 10
22124       MHARD = MHPOM
22125
22126 C  phase space limitation (single hard valence-valence quark scattering)
22127       IF(MHPOM.GT.0) THEN
22128         Emin = 2.D0*PTWANT + 0.2D0
22129         IF(ECMP.LT.Emin) THEN
22130           IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22131      &      'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22132           IREJ = 50
22133           IFAIL(6) = IFAIL(6) + 1
22134           RETURN
22135         ENDIF
22136       ENDIF
22137
22138       SAS    = PARMDL(160+II)/ECMP
22139       SAH    = 2.D0*PTWANT/ECMP
22140       AS     = SAS**2
22141       AH     = SAH**2
22142
22143 C  save energy for leading particle effect
22144       XMAXP1 = 1.D0
22145       if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22146       XMAXP2 = 1.D0
22147       if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22148
22149 C
22150 C  main loop to select hard and soft parton kinematics
22151 C -----------------------------------------------------
22152       IFAIL(31) = IFAIL(31)+MHARD
22153  20   CONTINUE
22154         IREJ  = 0
22155         IHARD = 0
22156         LSC1HD = 0
22157         ITRY  = ITRY+1
22158         IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22159         IF(ITRY.GE.NTRY) THEN
22160           IREJ = 1
22161           GOTO 450
22162         ENDIF
22163         LINE   = 0
22164         LSCAHD = 0
22165         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22166           XSS1   = MAX(0.D0,1.D0-XPSUB)
22167           XSS2   = MAX(0.D0,1.D0-XTSUB)
22168         ELSE
22169           XSS1   = 0.D0
22170           XSS2   = 0.D0
22171         ENDIF
22172  22     continue
22173
22174 C  partons needed to construct soft/hard interactions
22175         MSPAR1 = 2*MSPOM+MSREG+MHPOM
22176         MSPAR2 = MSPAR1
22177         MHPAR1 = MHPOM
22178         MHPAR2 = MHPOM
22179
22180 C  number of strings
22181         MSCHA = 2*MSPOM+MSREG
22182         MHCHA = 2*MHPOM
22183
22184         KSOFT = MSCHA
22185         KHARD = MHCHA
22186
22187 C  check actual phase space limit
22188         XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22189         IF(XX.GE.1.D0) THEN
22190           IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22191      &      'PHO_POMSCA: internal kin. rejection ',
22192      &      '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22193      &      MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22194           if(MSPOM+MSREG+MHPOM.gt.1) then
22195             if(MSREG.gt.0) then
22196               MSREG = MSREG-1
22197             else if(MSPOM.gt.0) THEN
22198               MSPOM = MSPOM-1
22199             else if(MHPOM.gt.1) then
22200               MHPOM = MHPOM-1
22201             endif
22202             goto 22
22203           endif
22204           IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22205      &      'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22206           IREJ = 50
22207           IFAIL(6) = IFAIL(6) + 1
22208           RETURN
22209         ENDIF
22210
22211         XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22212         XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22213
22214 C  very low energy phase space restriction
22215         if(MHARD.gt.0) then
22216           if((XMAXX1*XMAXX2.le.AH)) then
22217             IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22218      &        'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22219             IREJ = 50
22220             IFAIL(6) = IFAIL(6) + 1
22221             RETURN
22222           endif
22223         endif
22224
22225         AS = MAX(AS,PSOMIN/PCMP)
22226         ALNS  = LOG(AS)
22227         ALNH  = LOG(AH)
22228         Z1MAX = LOG(XMAXX1)
22229         Z2MAX = LOG(XMAXX2)
22230         Z1DIF = Z1MAX+Z2MAX-ALNH
22231         Z2DIF = Z1DIF
22232         PTMAX = 0.D0
22233 C
22234 C  select hard parton momenta
22235 C ------------------- begin of inner loop -------------------
22236         IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22237         IF(MHARD.GT.MSCAHD) THEN
22238           WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22239      &      'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22240           IREJ = 1
22241           RETURN
22242         ENDIF
22243         DO 11 NN=1,MHARD
22244 C
22245 C  generate one resolved hard scattering
22246 C
22247 C  high-pt option
22248           IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22249             CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22250      &                  -1,Max_pro_2,1,4,MSPOM+MHPOM)
22251             XSCUT = HSig(9)
22252             AHS    = AH
22253             ALNHS  = ALNH
22254             Z1DIFS = Z1DIF
22255             Z2DIFS = Z2DIF
22256             AH    = (2.D0*PTWANT/ECMP)**2
22257             ALNH  = LOG(AH)
22258             Z1DIF = Z1MAX+Z2MAX-ALNH
22259             Z2DIF = Z1DIF
22260             IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22261               IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22262      &          'PHO_POMSCA: kin.rejection, high-pt option ',
22263      &          '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22264               IREJ = 5
22265               RETURN
22266             ENDIF
22267             CALL PHO_HARSCA(2,II)
22268             CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22269      &                  -1,Max_pro_2,1,4,MSPOM+MHPOM)
22270             AH    = AHS
22271             ALNH  = ALNHS
22272             Z1DIF = Z1DIFS
22273             Z2DIF = Z2DIFS
22274             IPOWGC(4+II) = IPOWGC(4+II)+1
22275             HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22276 C  minimum bias option
22277           ELSE
22278             CALL PHO_HARSCA(2,II)
22279           ENDIF
22280
22281 C  fill /POHSLT/
22282           LSIDX(NN)    = NN
22283           LSCAHD       = NN
22284           XHD(NN,1)    = X1
22285           XHD(NN,2)    = X2
22286           X0HD(NN,1)   = X1
22287           X0HD(NN,2)   = X2
22288           VHD(NN)      = V
22289           ETAHD(NN,1)  = ETAC
22290           ETAHD(NN,2)  = ETAD
22291           PTHD(NN)     = PT
22292           NPROHD(NN)   = MSPR
22293           Q2SCA(NN,1)  = QQPD
22294           Q2SCA(NN,2)  = QQPD
22295           PDFVA(NN,1)  = PDF1(IA)
22296           PDFVA(NN,2)  = PDF2(IB)
22297           NINHD(NN,1)  = IA
22298           NINHD(NN,2)  = IB
22299           N0INHD(NN,1) = IA
22300           N0INHD(NN,2) = IB
22301           NIVAL(NN,1)  = IV1
22302           NIVAL(NN,2)  = IV2
22303           N0IVAL(NN,1) = IV1
22304           N0IVAL(NN,2) = IV2
22305           NOUTHD(NN,1) = IC
22306           NOUTHD(NN,2) = ID
22307           NBRAHD(NN,1) = IDPDG1
22308           NBRAHD(NN,2) = IDPDG2
22309           I3 = 8*(NN-1)
22310           I4 = 8*(NN-1)+4
22311           DO 50 I=1,4
22312             PPH(I3+I,1) = PHI1(I)
22313             PPH(I3+I,2) = PHI2(I)
22314             PPH(I4+I,1) = PHO1(I)
22315             PPH(I4+I,2) = PHO2(I)
22316  50       CONTINUE
22317
22318  11     CONTINUE
22319
22320 C  sort according to pt-hat
22321         DO 12 NN=1,MHARD
22322           PTMX = PTHD(LSIDX(NN))
22323           IPTM = NN
22324           DO 13 I=NN+1,MHARD
22325             IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22326               IPTM = I
22327               PTMX = PTHD(LSIDX(I))
22328             ENDIF
22329  13       CONTINUE
22330           IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22331  12     CONTINUE
22332         IPTM = LSIDX(1)
22333
22334 C  copy partons, generate ISR
22335         DO 15 L=1,MHARD
22336           NN = LSIDX(L)
22337           XSSS1  = XSS1+XHD(NN,1)
22338           XSSS2  = XSS2+XHD(NN,2)
22339 C  debug output
22340           IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22341      &      'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22342      &      L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22343 C  check phase space
22344           IF(    (XSSS1.GT.XMAXX1)
22345      &       .OR.(XSSS2.GT.XMAXX2)
22346      &       .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22347             IF(IHARD.EQ.0) THEN
22348               IF(ISWMDL(2).NE.1) GOTO 20
22349               MHPOM = 0
22350               MSPOM = 1
22351               MSREG = 0
22352             ENDIF
22353             GOTO 199
22354           ENDIF
22355
22356 C  reweight according to photon virtuality
22357           IF(IPAMDL(115).GE.1) THEN
22358             QQPD = Q2SCA(NN,1)
22359             WGX = 1.D0
22360             IF(IDPDG1.EQ.22) THEN
22361               IF(IPAMDL(115).EQ.1) THEN
22362                 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22363                   WG1 = 0.D0
22364                 ELSE
22365                   WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22366      &                 /LOG(QQPD/PARMDL(144))
22367                 ENDIF
22368                 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22369               ELSE IF(IPAMDL(115).EQ.2) THEN
22370                 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22371                 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22372               ENDIF
22373               WGX = WG1
22374             ENDIF
22375             QQPD = Q2SCA(NN,2)
22376             IF(IDPDG2.EQ.22) THEN
22377               IF(IPAMDL(115).EQ.1) THEN
22378                 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22379                   WG1 = 0.D0
22380                 ELSE
22381                   WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22382      &                 /LOG(QQPD/PARMDL(144))
22383                 ENDIF
22384                 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22385               ELSE IF(IPAMDL(115).EQ.2) THEN
22386                 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22387                 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22388               ENDIF
22389               WGX = WGX*WG1
22390             ENDIF
22391
22392             IF(IDEB(24).GE.25)
22393      &        WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22394      &          ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22395      &          KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22396
22397             IF(WGX.LT.DT_RNDM(WGX)) THEN
22398               IF(L.EQ.1) THEN
22399                 IREJ = 50
22400                 RETURN
22401               ELSE
22402                 GOTO 199
22403               ENDIF
22404             ENDIF
22405
22406             IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22407      &        'PHO_POMSCA: ',
22408      &        'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22409      &        KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22410
22411           ENDIF
22412
22413 C  generate ISR
22414           IF((ISWMDL(8).GE.2)
22415      &       .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22416             IF(IPAMDL(109).EQ.1) THEN
22417               Q2H = PARMDL(93)*PTHD(NN)**2
22418             ELSE
22419               Q2H = -PARMDL(93)*VHD(NN)
22420      &              *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22421             ENDIF
22422             XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22423             XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22424             I3     = 8*NN-4
22425             DO 42 J=1,4
22426               P1(J) = PPH(I3+J,1)
22427               P2(J) = PPH(I3+J,2)
22428  42         CONTINUE
22429             IF(IDEB(24).GE.10)
22430      &        WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22431      &          'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22432      &          L,NN,XHD(NN,1),XHD(NN,2),Q2H
22433             J = NN
22434             IF(L.EQ.1) J = -NN
22435             CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22436      &        N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22437      &        X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22438      &        NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22439             XSSS1 = XSSS1+XISR1-XHD(NN,1)
22440             XSSS2 = XSSS2+XISR2-XHD(NN,2)
22441             NINHD(NN,1) = IFL1
22442             NINHD(NN,2) = IFL2
22443             XHD(NN,1) = XISR1
22444             XHD(NN,2) = XISR2
22445           ENDIF
22446
22447 C  check phase space
22448           IF(    (XSSS1.GT.XMAXX1)
22449      &       .OR.(XSSS2.GT.XMAXX2)
22450      &       .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22451             IF(IHARD.EQ.0) THEN
22452               IF(ISWMDL(2).NE.1) GOTO 20
22453               MHPOM = 0
22454               MSPOM = 1
22455               MSREG = 0
22456             ENDIF
22457             GOTO 199
22458           ENDIF
22459
22460 C  leave energy for leading particle effect
22461           IF((IHARD.GT.0).AND.
22462      &       ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22463             GOTO 199
22464           endif
22465
22466 C  hard scattering accepted
22467           IHARD = IHARD+1
22468           XSS1 = XSSS1
22469           XSS2 = XSSS2
22470           IFAIL(31) = IFAIL(31)-1
22471
22472  15     CONTINUE
22473
22474 C ------------------- end of inner (hard) loop -------------------
22475  199    CONTINUE
22476
22477         MHPOM =  IHARD
22478         MHPAR1 = IHARD
22479         MHPAR2 = IHARD
22480
22481 C  count valences involved in hard scattering
22482         IVAL1  = 0
22483         IVAL2  = 0
22484         DO 17 L=1,IHARD
22485           NN = LSIDX(L)
22486           IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22487           IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22488  17     CONTINUE
22489
22490         IQUA1  = 0
22491         IQUA2  = 0
22492         IVGLU1 = 0
22493         IVGLU2 = 0
22494         DO 18 L=1,IHARD
22495           NN = LSIDX(L)
22496
22497 C  photon, pomeron valences
22498           IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22499             IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22500               NIVAL(NN,1) = 1
22501               IVAL1 = NN
22502             ENDIF
22503           ENDIF
22504           IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22505             IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22506               NIVAL(NN,2) = 1
22507               IVAL2 = NN
22508             ENDIF
22509           ENDIF
22510
22511 C  total number of quarks
22512           IF(NINHD(NN,1).NE.0) THEN
22513             IQUA1 = IQUA1+1
22514           ELSE IF(IVGLU1.EQ.0) THEN
22515             IVGLU1 = NN
22516           ENDIF
22517           IF(NINHD(NN,2).NE.0) THEN
22518             IQUA2 = IQUA2+1
22519           ELSE IF(IVGLU2.EQ.0) THEN
22520             IVGLU2 = NN
22521           ENDIF
22522  18     CONTINUE
22523
22524 C  gluons emitted by valence quarks
22525         VALPRO = 1.D0
22526         IF(II.EQ.1) VALPRO = VALPRG(1)
22527         IVQ1 = 1
22528         IVG1 = 0
22529         IVAL1 = MAX(IVAL1,0)
22530         IF(IVAL1.EQ.0) THEN
22531           IVQ1 = 0
22532           IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22533             IVAL1 = -IVGLU1
22534             IVG1 = 1
22535           ENDIF
22536         ENDIF
22537         VALPRO = 1.D0
22538         IF(II.EQ.1) VALPRO = VALPRG(2)
22539         IVQ2 = 1
22540         IVG2 = 0
22541         IVAL2 = MAX(IVAL2,0)
22542         IF(IVAL2.EQ.0) THEN
22543           IVQ2 = 0
22544           IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22545             IVAL2 = -IVGLU2
22546             IVG2 = 1
22547           ENDIF
22548         ENDIF
22549         MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22550 C  debug output
22551         IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22552      &    'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22553      &    IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22554
22555 C  select soft X values
22556  25     CONTINUE
22557 C  number of soft/remnant quarks
22558         IF(MSPOM.EQ.0) THEN
22559           IF(IPAMDL(18).EQ.0) THEN
22560             MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22561             MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22562           ELSE
22563             MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22564             MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22565           ENDIF
22566         ELSE
22567           IF(IPAMDL(18).EQ.0) THEN
22568             MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22569             MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22570           ELSE
22571             MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22572             MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22573           ENDIF
22574         ENDIF
22575 C  debug output
22576         IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22577      &    'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22578      &    MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22579
22580         XMAX1  = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22581         XMAX2  = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22582         I1 = IVQ1
22583         I2 = IVQ2
22584         IF(IVAL1.LE.0) I1 = 0
22585         IF(IVAL2.LE.0) I2 = 0
22586         IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22587           MSDIFF = 2*MSPOM
22588         ELSE
22589           MSDIFF = 2*MAX(0,MSPOM-1)
22590         ENDIF
22591         MSG1 = MSPAR1
22592         MSG2 = MSPAR2
22593         MSM1 = MSPAR1-MSDIFF
22594         MSM2 = MSPAR2-MSDIFF
22595         XMAXH1 = MIN(XMAX1,PARMDL(44))
22596         XMAXH2 = MIN(XMAX2,PARMDL(44))
22597         CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22598      &              XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22599
22600 C  correct for proper simulation of high pt tail
22601         IF(IREJ.NE.0) THEN
22602           IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22603      &      'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22604      &      MSPOM,MHPOM,I1,I2
22605           IF(MSPOM*MHPOM.GT.0) THEN
22606             MSPOM = MSPOM-1
22607             GOTO 25
22608           ELSE IF(MSPOM.GT.1) THEN
22609             MSPOM = MSPOM-1
22610             GOTO 25
22611           ELSE IF(MHPOM.GT.1) THEN
22612             IHARD = IHARD-1
22613             IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22614      &         .AND.(IPROCE.EQ.1)) THEN
22615               XSS1   = MAX(0.D0,1.D0-XPSUB)
22616               XSS2   = MAX(0.D0,1.D0-XTSUB)
22617             ELSE
22618               XSS1   = 0.D0
22619               XSS2   = 0.D0
22620             ENDIF
22621             DO 103 K=1,IHARD
22622               I = LSIDX(K)
22623               XSS1 = XSS1+ XHD(I,1)
22624               XSS2 = XSS2+ XHD(I,2)
22625  103        CONTINUE
22626             GOTO 199
22627           ENDIF
22628           IREJ = 4
22629           GOTO 450
22630         ENDIF
22631 C  accepted
22632         MSPOM  = MSPOM-(MSPAR1-MSG1)/2
22633         MSPAR1 = MSG1
22634         MSPAR2 = MSG2
22635 C  ------------ kinematics sampled ---------------
22636 C  debug output
22637         IF(IDEB(24).GE.10) THEN
22638           WRITE(LO,'(1X,A,I3)')
22639      &      'PHO_POMSCA: soft x values, ITRY',ITRY
22640           DO 104 I=2,MAX(MSPAR1,MSPAR2)
22641             WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22642  104      CONTINUE
22643         ENDIF
22644       IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22645
22646 C  end of loop
22647       XS1(1) = 1.D0 - XSS1
22648       XS2(1) = 1.D0 - XSS2
22649
22650 C  process counting
22651       DO 30 N=1,LSCAHD
22652         MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22653  30   CONTINUE
22654
22655 C  soft particle momenta
22656       IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22657         WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22658      &    '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22659         IREJ = 1
22660         RETURN
22661       ENDIF
22662       DO 55 I=1,MSPAR1
22663         PSOFT1(1,I) = 0.D0
22664         PSOFT1(2,I) = 0.D0
22665         PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22666         PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22667  55   CONTINUE
22668       DO 60 I=1,MSPAR2
22669         PSOFT2(1,I) = 0.D0
22670         PSOFT2(2,I) = 0.D0
22671         PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22672         PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22673  60   CONTINUE
22674
22675       KSOFT = MAX(MSPAR1,MSPAR2)
22676       KHARD = MAX(MHPAR1,MHPAR2)
22677       KSPOM = MSPOM
22678       KSREG = MSREG
22679       KHPOM = MHPOM
22680
22681 C  debug output
22682       IF(IDEB(24).GE.10) THEN
22683         WRITE(LO,'(/1X,A,2I3,2I5)')
22684      &    'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22685      &     IVAL1,IVAL2,ITRY,NTRY
22686         IF(MSPAR1+MSPAR2.GT.0) THEN
22687           WRITE(LO,'(5X,A)') 'soft x particle1   particle2:'
22688           XTMP1 = 0.D0
22689           XTMP2 = 0.D0
22690           DO 105 I=1,MAX(MSPAR1,MSPAR2)
22691             IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22692               WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22693               XTMP1 = XTMP1+XS1(I)
22694               XTMP2 = XTMP2+XS2(I)
22695             ELSE IF(I.LE.MSPAR1) THEN
22696               WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22697               XTMP1 = XTMP1+XS1(I)
22698             ELSE IF(I.LE.MSPAR2) THEN
22699               WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22700               XTMP2 = XTMP2+XS2(I)
22701             ENDIF
22702  105      CONTINUE
22703           WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22704         ENDIF
22705         IF(MHPAR1.GT.0) THEN
22706           WRITE(LO,'(5X,A)')
22707      &      'NR  IDX  MSPR hard X / hard X ISR / flavor particle 1,2:'
22708           DO 107 K=1,MHPAR1
22709             I = LSIDX(K)
22710             WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22711      &        K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22712      &        NINHD(I,1),NINHD(I,2)
22713               XTMP1 = XTMP1+XHD(I,1)
22714               XTMP2 = XTMP2+XHD(I,2)
22715  107      CONTINUE
22716           WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22717           WRITE(LO,'(5X,A)') 'hard momenta  particle1:'
22718           DO 108 K=1,MHPAR1
22719             I = LSIDX(K)
22720             I3 = 8*I-4
22721             WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22722      &        NOUTHD(I,1)
22723  108      CONTINUE
22724           WRITE(LO,'(5X,A)') 'hard momenta  particle2:'
22725           DO 110 K=1,MHPAR2
22726             I = LSIDX(K)
22727             I3 = 8*I-4
22728             WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22729      &        NOUTHD(I,2)
22730  110      CONTINUE
22731         ENDIF
22732       ENDIF
22733       RETURN
22734
22735 C  event rejected, print debug information
22736  450  CONTINUE
22737       IFAIL(4) = IFAIL(4)+1
22738       IF(IDEB(24).GE.2) THEN
22739         WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22740      &    'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22741      &    MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22742         WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22743         IF(IDEB(24).GE.5) THEN
22744           CALL PHO_PREVNT(0)
22745         ELSE
22746           CALL PHO_PREVNT(-1)
22747         ENDIF
22748       ENDIF
22749
22750       END
22751
22752 *$ CREATE PHO_HARX12.FOR
22753 *COPY PHO_HARX12
22754 CDECK  ID>, PHO_HARX12
22755       SUBROUTINE PHO_HARX12
22756 C**********************************************************************
22757 C
22758 C     selection of x1 and x2 according to 1/x1*1/x2
22759 C
22760 C**********************************************************************
22761       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22762       SAVE
22763
22764       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22765
22766 C  input/output channels
22767       INTEGER LI,LO
22768       COMMON /POINOU/ LI,LO
22769 C  data on most recent hard scattering
22770       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22771       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22772      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22773      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22774       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22775      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22776      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22777      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22778      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22779
22780 10    CONTINUE
22781         Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22782         Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
22783         IF ( (Z1+Z2).LT.ALNH ) GOTO 10
22784       X1   = EXP(Z1)
22785       X2   = EXP(Z2)
22786       AXX  = AH/(X1*X2)
22787       W    = SQRT(MAX(TINY,1.D0-AXX))
22788       W1   = AXX/(1.D0+W)
22789
22790       END
22791
22792 *$ CREATE PHO_HARDX1.FOR
22793 *COPY PHO_HARDX1
22794 CDECK  ID>, PHO_HARDX1
22795       SUBROUTINE PHO_HARDX1
22796 C**********************************************************************
22797 C
22798 C     selection of x1 according to 1/x1
22799 C     ( x2 = 1 )
22800 C
22801 C**********************************************************************
22802       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22803       SAVE
22804
22805       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22806
22807 C  input/output channels
22808       INTEGER LI,LO
22809       COMMON /POINOU/ LI,LO
22810 C  data on most recent hard scattering
22811       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22812       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22813      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22814      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22815       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22816      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22817      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22818      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22819      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22820
22821       Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22822       X2   = 1.D0
22823       X1   = EXP(Z1)
22824       AXX  = AH/X1
22825       W    = SQRT(MAX(TINY,1.D0-AXX))
22826       W1   = AXX/(1.D0+W)
22827
22828       END
22829
22830 *$ CREATE PHO_HARKIN.FOR
22831 *COPY PHO_HARKIN
22832 CDECK  ID>, PHO_HARKIN
22833       SUBROUTINE PHO_HARKIN(IREJ)
22834 C***********************************************************************
22835 C
22836 C     selection of kinematic variables
22837 C     (resolved and direct processes)
22838 C
22839 C***********************************************************************
22840       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22841       SAVE
22842
22843       PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
22844
22845 C  input/output channels
22846       INTEGER LI,LO
22847       COMMON /POINOU/ LI,LO
22848 C  event debugging information
22849       INTEGER NMAXD
22850       PARAMETER (NMAXD=100)
22851       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22852      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22853       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22854      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22855 C  data of c.m. system of Pomeron / Reggeon exchange
22856       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22857       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22858      &                 SIDP,CODP,SIFP,COFP
22859       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22860      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
22861      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
22862 C  data on most recent hard scattering
22863       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22864       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22865      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22866      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22867       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22868      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22869      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22870      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22871      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22872 C  internal cross check information on hard scattering limits
22873       DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
22874       COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
22875
22876       PARAMETER ( Max_pro_2 = 16 )
22877       DIMENSION RM(-1:Max_pro_2)
22878       DATA RM / 3.31D0, 0.0D0,
22879      &          7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
22880      &          0.45D0, 0.89D0, 0.89D0, 0.0D0,  4.776D0,
22881      &          0.615D0,4.776D0,0.615D0,1.0D0,  0.0D0,
22882      &          1.0D0 /
22883
22884       IREJ = 0
22885       M    = MSPR
22886
22887 C------------- resolved processes -----------
22888       IF     ( M.EQ.1 ) THEN
22889 10      CALL PHO_HARX12
22890         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22891         U  =-1.D0-V
22892         R  = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
22893         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22894      &    'PHO_HARKIN:weight error',M
22895         IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
22896         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22897       ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
22898 20      CALL PHO_HARX12
22899         WL = LOG(W1)
22900         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22901         U  =-1.D0-V
22902         R  = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
22903         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22904      &    'PHO_HARKIN:weight error',M
22905         IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
22906         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22907       ELSEIF ( M.EQ.3 ) THEN
22908 30      CALL PHO_HARX12
22909         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22910         U  =-1.D0-V
22911         R  = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
22912         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22913      &    'PHO_HARKIN:weight error',M
22914         IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
22915       ELSEIF ( M.EQ.5 ) THEN
22916 50      CALL PHO_HARX12
22917         V  =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22918         U  =-1.D0-V
22919         R  = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
22920         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22921      &    'PHO_HARKIN:weight error',M
22922         IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
22923       ELSEIF ( M.EQ.6 ) THEN
22924 60      CALL PHO_HARX12
22925         V  =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
22926         U  =-1.D0-V
22927         R  = (4.D0/9.D0)*(U*U+V*V)*AXX
22928         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22929      &    'PHO_HARKIN:weight error',M
22930         IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
22931       ELSEIF ( M.EQ.7 ) THEN
22932 70      CALL PHO_HARX12
22933         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22934         U  =-1.D0-V
22935         R  = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
22936      &       -(4.D0/27.D0)*V/U)
22937         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22938      &    'PHO_HARKIN:weight error',M
22939         IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
22940         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22941       ELSEIF ( M.EQ.8 ) THEN
22942 80      CALL PHO_HARX12
22943         V  =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22944         U  =-1.D0-V
22945         R  = (4.D0/9.D0)*(1.D0+U*U)
22946         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22947      &    'PHO_HARKIN:weight error',M
22948         IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
22949       ELSEIF ( M.EQ.-1 ) THEN
22950 90      CALL PHO_HARX12
22951         WL = LOG(W1)
22952         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22953         U  =-1.D0-V
22954         R  = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
22955         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22956      &    'PHO_HARKIN:weight error',M
22957         IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
22958 C------------- direct / single-resolved processes -----------
22959       ELSEIF ( M.EQ.10 ) THEN
22960 100     CALL PHO_HARDX1
22961         WL = LOG(AXX/(1.D0+W)**2)
22962         U  =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22963         R  = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
22964         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22965      &    'PHO_HARKIN:weight error',M
22966         IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
22967         V  =-1.D0-U
22968         X2 = X1
22969         X1 = 1.D0
22970       ELSEIF ( M.EQ.11) THEN
22971 110     CALL PHO_HARDX1
22972         WL = LOG(W1)
22973         U  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22974         V  =-1.D0-U
22975         R  = (U*U+V*V)/V*WL*AXX
22976         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22977      &    'PHO_HARKIN:weight error',M
22978         IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
22979         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22980         X2 = X1
22981         X1 = 1.D0
22982       ELSEIF ( M.EQ.12 ) THEN
22983 120     CALL PHO_HARDX1
22984         WL = LOG(AXX/(1.D0+W)**2)
22985         V  =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22986         R  = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
22987         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22988      &    'PHO_HARKIN:weight error',M
22989         IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
22990       ELSEIF ( M.EQ.13) THEN
22991 130     CALL PHO_HARDX1
22992         WL = LOG(W1)
22993         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22994         U  =-1.D0-V
22995         R  = (U*U+V*V)/U*WL*AXX
22996         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22997      &    'PHO_HARKIN:weight error',M
22998         IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
22999         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23000 C------------- (double) direct process -----------
23001       ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
23002         X1 = 1.D0
23003         X2 = 1.D0
23004         AXX= AH
23005         W  = SQRT(MAX(TINY,1.D0-AXX))
23006         W1 = AXX/(1.D0+W)
23007         WL = LOG(W1)
23008  140    V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23009         U  =-1.D0-V
23010         R  = -(U*U+V*V)/U
23011         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23012      &    'PHO_HARKIN:weight error',M
23013         IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
23014         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23015 C---------------------------------------------
23016       ELSE
23017         WRITE(LO,'(/1X,A,I3)')
23018      &    'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
23019         CALL PHO_ABORT
23020       ENDIF
23021
23022       V    = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23023       U    = -1.D0-V
23024       U    = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23025       PT   = SQRT(U*V*X1*X2)*ECMP
23026       ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23027       ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23028
23029 ***************************************************************
23030       MM = M
23031       IF(M.EQ.-1) MM = 3
23032       ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23033       ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23034       ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23035       ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23036       XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23037       XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23038       XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23039       XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23040 ***************************************************************
23041
23042       IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23043      &  'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23044
23045       END
23046
23047 *$ CREATE PHO_HARWGH.FOR
23048 *COPY PHO_HARWGH
23049 CDECK  ID>, PHO_HARWGH
23050       SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23051 C***********************************************************************
23052 C
23053 C     calculate product of PDFs and coupling constants
23054 C     according to selected MSPR (process type)
23055 C
23056 C     input:    /POCKIN/
23057 C
23058 C     output:   PDS     resulting from PDFs alone
23059 C               FDISTR  complete weight function
23060 C               PDA,PDB fields containing the PDFs
23061 C
23062 C***********************************************************************
23063       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23064       SAVE
23065
23066       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23067
23068 C  input/output channels
23069       INTEGER LI,LO
23070       COMMON /POINOU/ LI,LO
23071 C  event debugging information
23072       INTEGER NMAXD
23073       PARAMETER (NMAXD=100)
23074       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23075      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23076       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23077      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23078 C  model switches and parameters
23079       CHARACTER*8 MDLNA
23080       INTEGER ISWMDL,IPAMDL
23081       DOUBLE PRECISION PARMDL
23082       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23083 C  data of c.m. system of Pomeron / Reggeon exchange
23084       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23085       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23086      &                 SIDP,CODP,SIFP,COFP
23087       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23088      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23089      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23090 C  currently activated parton density parametrizations
23091       CHARACTER*8 PDFNAM
23092       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23093       DOUBLE PRECISION PDFLAM,PDFQ2M
23094       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23095      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23096 C  hard scattering parameters used for most recent hard interaction
23097       INTEGER NFbeta,NF
23098       DOUBLE PRECISION ALQCD2,BQCD
23099       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23100 C  some hadron information, will be deleted in future versions
23101       INTEGER NFS
23102       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23103       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23104 C  scale parameters for parton model calculations
23105       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23106       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23107       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23108      &                NQQAL,NQQALI,NQQALF,NQQPD
23109 C  data on most recent hard scattering
23110       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23111       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23112      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23113      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23114       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23115      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23116      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23117      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23118      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23119 C  hard cross sections and MC selection weights
23120       INTEGER Max_pro_2
23121       PARAMETER ( Max_pro_2 = 16 )
23122       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23123      &  MH_acc_1,MH_acc_2
23124       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23125       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23126      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23127      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23128      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23129      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23130 C  some constants
23131       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23132       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23133      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23134
23135       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23136       DIMENSION PDA(-6:6),PDB(-6:6)
23137
23138       FDISTR = 0.D0
23139 C  set hard scale  QQ  for alpha and partondistr.
23140       IF     ( NQQAL.EQ.1 ) THEN
23141         QQAL = AQQAL*PT*PT
23142       ELSEIF ( NQQAL.EQ.2 ) THEN
23143         QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23144       ELSEIF ( NQQAL.EQ.3 ) THEN
23145         QQAL = AQQAL*X1*X2*ECMP*ECMP
23146       ELSEIF ( NQQAL.EQ.4 ) THEN
23147         QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23148       ENDIF
23149       IF     ( NQQPD.EQ.1 ) THEN
23150         QQPD = AQQPD*PT*PT
23151       ELSEIF ( NQQPD.EQ.2 ) THEN
23152         QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23153       ELSEIF ( NQQPD.EQ.3 ) THEN
23154         QQPD = AQQPD*X1*X2*ECMP*ECMP
23155       ELSEIF ( NQQPD.EQ.4 ) THEN
23156         QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23157       ENDIF
23158 C  coupling constants, PDFs
23159       IF(MSPR.LT.9) THEN
23160         ALPHA1 = PHO_ALPHAS(QQAL,3)
23161         ALPHA2 = ALPHA1
23162         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23163         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23164         IF ( MSPR.EQ.1  .OR.  MSPR.EQ.4 ) THEN
23165           PDS   = PDA(0)*PDB(0)
23166         ELSE
23167           S2    = 0.D0
23168           S3    = 0.D0
23169           S4    = 0.D0
23170           S5    = 0.D0
23171           DO 10 I=1,NF
23172             S2  = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23173             S3  = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23174             S4  = S4+PDA(I)+PDA(-I)
23175             S5  = S5+PDB(I)+PDB(-I)
23176  10       CONTINUE
23177           IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23178             PDS = S2
23179           ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23180             PDS = PDA(0)*S5+PDB(0)*S4
23181           ELSE IF(MSPR.EQ.7) THEN
23182             PDS = S3
23183           ELSE IF(MSPR.EQ.8) THEN
23184             PDS = S4*S5-(S2+S3)
23185           ENDIF
23186         ENDIF
23187       ELSE IF(MSPR.LT.12) THEN
23188         ALPHA2 = PHO_ALPHAS(QQAL,2)
23189         IF(IDPDG1.EQ.22) THEN
23190           ALPHA1 = pho_alphae(QQAL)
23191         ELSE IF(IDPDG1.EQ.990) THEN
23192           ALPHA1 = PARMDL(74)
23193         ENDIF
23194         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23195         S4    = 0.D0
23196         S6    = 0.D0
23197         DO 15 I=1,NF
23198           S4  = S4+PDB(I)+PDB(-I)
23199 C  charge counting
23200 *         IF(MOD(I,2).EQ.0) THEN
23201 *           S6  = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23202 *         ELSE
23203 *           S6  = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23204 *         ENDIF
23205           S6  = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23206  15     CONTINUE
23207         IF(MSPR.EQ.10) THEN
23208           IF(IDPDG1.EQ.990) THEN
23209             PDS = S4
23210           ELSE
23211             PDS = S6
23212           ENDIF
23213         ELSE
23214           PDS = PDB(0)
23215         ENDIF
23216       ELSE IF(MSPR.LT.14) THEN
23217         ALPHA1 = PHO_ALPHAS(QQAL,1)
23218         IF(IDPDG2.EQ.22) THEN
23219           ALPHA2 = pho_alphae(QQAL)
23220         ELSE IF(IDPDG2.EQ.990) THEN
23221           ALPHA2 = PARMDL(74)
23222         ENDIF
23223         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23224         S4    = 0.D0
23225         S6    = 0.D0
23226         DO 20 I=1,NF
23227           S4  = S4+PDA(I)+PDA(-I)
23228 C  charge counting
23229 *         IF(MOD(I,2).EQ.0) THEN
23230 *           S6  = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23231 *         ELSE
23232 *           S6  = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23233 *         ENDIF
23234           S6  = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23235  20     CONTINUE
23236         IF(MSPR.EQ.12) THEN
23237           IF(IDPDG2.EQ.990) THEN
23238             PDS = S4
23239           ELSE
23240             PDS = S6
23241           ENDIF
23242         ELSE
23243           PDS = PDA(0)
23244         ENDIF
23245       ELSE IF(MSPR.EQ.14) THEN
23246         SSR = X1*X2*ECMP*ECMP
23247         IF(IDPDG1.EQ.22) THEN
23248           ALPHA1 = pho_alphae(SSR)
23249         ELSE IF(IDPDG1.EQ.990) THEN
23250           ALPHA1 = PARMDL(74)
23251         ENDIF
23252         IF(IDPDG2.EQ.22) THEN
23253           ALPHA2 = pho_alphae(SSR)
23254         ELSE IF(IDPDG2.EQ.990) THEN
23255           ALPHA2 = PARMDL(74)
23256         ENDIF
23257         PDS = 1.D0
23258       ELSE
23259         WRITE(LO,'(/1X,A,I4)')
23260      &    'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23261         CALL PHO_ABORT
23262       ENDIF
23263
23264 C  complete weight
23265       FDISTR  = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23266
23267 C  debug output
23268       IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23269      &    'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23270      &    MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23271
23272       END
23273
23274 *$ CREATE PHO_HARSCA.FOR
23275 *COPY PHO_HARSCA
23276 CDECK  ID>, PHO_HARSCA
23277       SUBROUTINE PHO_HARSCA(IMODE,IP)
23278 C***********************************************************************
23279 C
23280 C     PHO_HARSCA determines the type of hard subprocess, the partons
23281 C     taking part in this subprocess and the kinematic variables
23282 C
23283 C     input:  IMODE   1   direct processes
23284 C                     2   resolved processes
23285 C                     -1  initialization
23286 C                     -2  output of statistics
23287 C             IP      1-4 particle combination (hadron/photon)
23288 C
23289 C***********************************************************************
23290       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23291       SAVE
23292
23293       PARAMETER( EPS  = 1.D-10,
23294      &           DEPS = 1.D-30 )
23295
23296 C  input/output channels
23297       INTEGER LI,LO
23298       COMMON /POINOU/ LI,LO
23299 C  event debugging information
23300       INTEGER NMAXD
23301       PARAMETER (NMAXD=100)
23302       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23303      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23304       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23305      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23306 C  model switches and parameters
23307       CHARACTER*8 MDLNA
23308       INTEGER ISWMDL,IPAMDL
23309       DOUBLE PRECISION PARMDL
23310       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23311 C  internal rejection counters
23312       INTEGER NMXJ
23313       PARAMETER (NMXJ=60)
23314       CHARACTER*10 REJTIT
23315       INTEGER IFAIL
23316       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23317 C  hard scattering parameters used for most recent hard interaction
23318       INTEGER NFbeta,NF
23319       DOUBLE PRECISION ALQCD2,BQCD
23320       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23321 C  data of c.m. system of Pomeron / Reggeon exchange
23322       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23323       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23324      &                 SIDP,CODP,SIFP,COFP
23325       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23326      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23327      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23328 C  names of hard scattering processes
23329       INTEGER Max_pro_1
23330       PARAMETER ( Max_pro_1 = 16 )
23331       CHARACTER*18 PROC
23332       COMMON /POHPRO/ PROC(0:Max_pro_1)
23333 C  data on most recent hard scattering
23334       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23335       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23336      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23337      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23338       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23339      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23340      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23341      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23342      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23343 C  hard scattering data
23344       INTEGER MSCAHD
23345       PARAMETER ( MSCAHD = 50 )
23346       INTEGER LSCAHD,LSC1HD,LSIDX,
23347      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23348       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23349       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23350      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23351      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23352      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23353      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23354      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23355      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23356 C  hard cross sections and MC selection weights
23357       INTEGER Max_pro_2
23358       PARAMETER ( Max_pro_2 = 16 )
23359       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23360      &  MH_acc_1,MH_acc_2
23361       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23362       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23363      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23364      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23365      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23366      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23367 C  cross sections
23368       INTEGER IPFIL,IFAFIL,IFBFIL
23369       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23370      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23371      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23372      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23373      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23374       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23375      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23376      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23377      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23378      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23379      &                IPFIL,IFAFIL,IFBFIL
23380 C  some constants
23381       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23382       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23383      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23384
23385  111  CONTINUE
23386
23387 C  resolved processes
23388       IF(IMODE.EQ.2) THEN
23389
23390         MH_pro_on(0,IP) = 0
23391         HWgx(9)  = 0.D0
23392         DO 15 M=-1,8
23393           IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23394  15     CONTINUE
23395         IF(HWgx(9).LT.DEPS) THEN
23396           WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23397      &      'no resolved process possible for IP',IP,HWgx(9)
23398           CALL PHO_ABORT
23399         ENDIF
23400 C
23401 C ----------------------------------------------I
23402 C  begin of iteration loop (resolved processes) I
23403 C                                               I
23404         IREJSC = 0
23405  10     CONTINUE
23406         IREJSC = IREJSC+1
23407         IF(IREJSC.GT.1000) THEN
23408           WRITE(LO,'(/1X,A,I10)')
23409      &      'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23410             CALL PHO_ABORT
23411         ENDIF
23412
23413 C  find subprocess
23414         B      = DT_RNDM(X1)*HWgx(9)
23415         MSPR   =-2
23416         SUM    = 0.D0
23417  20     MSPR   = MSPR+1
23418         IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23419         IF ( SUM.LT.B  .AND. MSPR.LT.8 ) GOTO 20
23420
23421         IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23422      &    'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23423
23424 C  find kin. variables X1,X2 and V
23425         CALL PHO_HARKIN(IREJ)
23426         IF(IREJ.NE.0) THEN
23427           IFAIL(29) = IFAIL(29)+1
23428           GOTO 10
23429         ENDIF
23430 C  calculate remaining distribution
23431         CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23432 C  actualize counter for cross-section calculation
23433         if(F.LE.1.D-15) then
23434           F = 0.D0
23435           goto 10
23436         endif
23437 *       XSECT(5,MSPR) = XSECT(5,MSPR)+F
23438 *       XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23439         MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23440 C  check F against FMAX
23441         WEIGHT = F/(HWgx(MSPR)+DEPS)
23442         IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23443 C-------------------------------------------------------------------
23444         IF(WEIGHT.GT.1.D0) THEN
23445           WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23446  1234     FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23447      &      2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23448           WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23449      &      ECMP,PTWANT,AS,AH,PT
23450           WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23451      &      ETAC,ETAD,X1,X2,V
23452           CALL PHO_PREVNT(-1)
23453         ENDIF
23454 C-------------------------------------------------------------------
23455 C                                             I
23456 C  end of iteration loop (resolved processes) I
23457 C --------------------------------------------I
23458 C
23459 C*********************************************************************
23460 C
23461 C  direct processes
23462
23463       ELSE IF(IMODE.EQ.1) THEN
23464
23465 C  single-resolved processes kinematically forbidden
23466         if(Z1DIF.lt.0.D0) then
23467           HWgx(10) = 0.D0
23468           HWgx(11) = 0.D0
23469           HWgx(12) = 0.D0
23470           HWgx(13) = 0.D0
23471         endif
23472
23473         HWgx(15)  = 0.D0
23474         if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23475           DO M= 10,14
23476             IF(MH_pro_on(M,IP).EQ.1) then
23477               if((M.eq.10).or.(M.eq.11)) then
23478                 fac = FSUH(1)*FSUP(2)
23479               else if((M.eq.12).or.(M.eq.13)) then
23480                 fac = FSUP(1)*FSUH(2)
23481               else
23482                 fac = FSUH(1)*FSUH(2)
23483               endif
23484               HWgx(15) = HWgx(15)+HWgx(M)*fac
23485             endif
23486           ENDDO
23487         else
23488           DO M= 10,14
23489             IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23490           ENDDO
23491         endif
23492         IF(HWgx(15).LT.DEPS) THEN
23493           WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23494      &      'no direct/single-resolved process possible (IP)',IP
23495           CALL PHO_ABORT
23496         ENDIF
23497 C
23498 C ----------------------------------------------I
23499 C  begin of iteration loop (direct processes)   I
23500 C                                               I
23501         IREJSC = 0
23502  100    CONTINUE
23503         IREJSC = IREJSC+1
23504         IF(IREJSC.GT.1000) THEN
23505           WRITE(LO,'(/1X,A,I10)')
23506      &      'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23507             CALL PHO_ABORT
23508         ENDIF
23509
23510 C  find subprocess
23511         B      = DT_RNDM(X1)*HWgx(15)
23512         MSPR   = 9
23513         SUM    = 0.D0
23514         if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23515  150      continue
23516             MSPR   = MSPR+1
23517             IF(MH_pro_on(MSPR,IP).EQ.1) then
23518               if((MSPR.eq.10).or.(MSPR.eq.11)) then
23519                 fac = FSUH(1)*FSUP(2)
23520               else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23521                 fac = FSUP(1)*FSUH(2)
23522               else
23523                 fac = FSUH(1)*FSUH(2)
23524               endif
23525               SUM = SUM+HWgx(MSPR)*fac
23526             endif
23527           IF ( SUM.LT.B  .AND. MSPR.LT.14 ) GOTO 150
23528         else
23529  200      continue
23530             MSPR   = MSPR+1
23531             IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23532           IF ( SUM.LT.B  .AND. MSPR.LT.14 ) GOTO 200
23533         endif
23534
23535         IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23536      &    'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23537
23538 C  find kin. variables X1,X2 and V
23539         CALL PHO_HARKIN(IREJ)
23540         IF(IREJ.NE.0) THEN
23541           IFAIL(28) = IFAIL(28)+1
23542           GOTO 100
23543         ENDIF
23544
23545 C  calculate remaining distribution
23546         CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23547
23548 C  counter for cross-section calculation
23549         if(F.LE.1.D-15) then
23550           F=0.D0
23551           goto 100
23552         endif
23553 *       XSECT(5,MSPR) = XSECT(5,MSPR)+F
23554 *       XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23555         MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23556 C  check F against FMAX
23557         WEIGHT = F/(HWgx(MSPR)+DEPS)
23558         IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23559 C-------------------------------------------------------------------
23560         IF(WEIGHT.GT.1.D0) THEN
23561           WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23562  1235     FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23563      &      2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23564           WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23565      &      ECMP,PTWANT,AS,AH,PT
23566           WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23567      &      ETAC,ETAD,X1,X2,V
23568           CALL PHO_PREVNT(-1)
23569         ENDIF
23570 C-------------------------------------------------------------------
23571 C                                             I
23572 C  end of iteration loop (direct processes)   I
23573 C --------------------------------------------I
23574
23575       ELSE IF(IMODE.EQ.-1) THEN
23576
23577 C  initialize cross section calculations
23578
23579         DO 40 M=-1,Max_pro_2
23580 *         DO 30 I=5,6
23581 *           XSECT(I,M) = 0.D0
23582 *30       CONTINUE
23583 C  reset counters
23584           DO 35 J=1,4
23585             MH_tried(M,J) = 0
23586             MH_acc_1(M,J) = 0
23587             MH_acc_2(M,J) = 0
23588  35       CONTINUE
23589  40     CONTINUE
23590         IF(IDEB(78).GE.0) THEN
23591           WRITE(LO,'(/1X,A,/1X,A)')
23592      &      'PHO_HARSCA: activated hard processes',
23593      &      '------------------------------------'
23594           WRITE(LO,'(5X,A)') 'PROCESS,    IP= 1 ... 4 (on/off)'
23595           DO 42 M=1,Max_pro_2
23596             WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23597      &        (MH_pro_on(M,J),J=1,4)
23598  42       CONTINUE
23599         ENDIF
23600         RETURN
23601
23602       ELSE IF(IMODE.EQ.-2) THEN
23603
23604 C  calculation of process statistics
23605
23606         do K=1,4
23607
23608           MH_tried(0,K)  = 0
23609           MH_acc_1(0,K)  = 0
23610           MH_acc_2(0,K)  = 0
23611           MH_tried(9,K)  = 0
23612           MH_acc_1(9,K)  = 0
23613           MH_acc_2(9,K)  = 0
23614           MH_tried(15,K) = 0
23615           MH_acc_1(15,K) = 0
23616           MH_acc_2(15,K) = 0
23617
23618           MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23619           MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23620           MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23621
23622           do M=1,8
23623             MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23624             MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23625             MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23626           enddo
23627           do M=10,14
23628             MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23629             MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23630             MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23631           enddo
23632           MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23633           MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23634           MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23635         enddo
23636
23637         IF(IDEB(78).GE.1) THEN
23638           WRITE(LO,'(/1X,A,/1X,A)')
23639      &      'PHO_HARSCA: internal rejection statistics',
23640      &      '-----------------------------------------'
23641           do K=1,4
23642             IF(MH_tried(0,K).GT.0) THEN
23643               WRITE(LO,'(5X,A,I3)')
23644      &          'process (sampled/accepted) for IP:',K
23645               do M=0,Max_pro_2
23646                 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23647      &            MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23648      &            dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23649               enddo
23650             ENDIF
23651           enddo
23652         ENDIF
23653         RETURN
23654
23655       ELSE
23656         WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23657      &    'unsupported mode',IMODE
23658         CALL PHO_ABORT
23659       ENDIF
23660
23661 C  the event is accepted now
23662 C  actualize counter for accepted events
23663       MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23664       IF(MSPR.EQ.-1) MSPR = 3
23665 C
23666 C  find flavor of initial partons
23667 C
23668       SUM    = 0.D0
23669       SCHECK = DT_RNDM(SUM)*PDS-EPS
23670       IF     ( MSPR.EQ.1  .OR.  MSPR.EQ.4 ) THEN
23671         IA = 0
23672         IB = 0
23673       ELSEIF ( MSPR.EQ.2  .OR.  MSPR.EQ.5  .OR.  MSPR.EQ.6 ) THEN
23674         DO 610 IA=-NF,NF
23675           IF ( IA.EQ.0 ) GOTO 610
23676           SUM  = SUM+PDF1(IA)*PDF2(-IA)
23677           IF ( SUM.GE.SCHECK ) GOTO 620
23678  610      CONTINUE
23679  620    IB =-IA
23680       ELSEIF ( MSPR.EQ.3 ) THEN
23681         IB     = 0
23682         DO 630 IA=-NF,NF
23683           IF ( IA.EQ.0 ) GOTO 630
23684           SUM  = SUM+PDF1(0)*PDF2(IA)
23685           IF ( SUM.GE.SCHECK ) GOTO 640
23686           SUM  = SUM+PDF1(IA)*PDF2(0)
23687           IF ( SUM.GE.SCHECK ) GOTO 650
23688  630    CONTINUE
23689  640    IB     = IA
23690         IA     = 0
23691  650    CONTINUE
23692       ELSEIF ( MSPR.EQ.7 ) THEN
23693         DO 660 IA=-NF,NF
23694           IF ( IA.EQ.0 ) GOTO 660
23695           SUM  = SUM+PDF1(IA)*PDF2(IA)
23696           IF ( SUM.GE.SCHECK ) GOTO 670
23697  660      CONTINUE
23698  670    IB     = IA
23699       ELSEIF ( MSPR.EQ.8 ) THEN
23700         DO 690 IA=-NF,NF
23701           IF ( IA.EQ.0 ) GOTO 690
23702           DO 680 IB=-NF,NF
23703             IF ( ABS(IB).EQ.ABS(IA)  .OR.  IB.EQ.0 ) GOTO 680
23704             SUM = SUM+PDF1(IA)*PDF2(IB)
23705             IF ( SUM.GE.SCHECK ) GOTO 700
23706  680        CONTINUE
23707  690      CONTINUE
23708  700    CONTINUE
23709       ELSEIF ( MSPR.EQ.10 ) THEN
23710         IA     = 0
23711         DO 710 IB=-NF,NF
23712           IF ( IB.NE.0 ) THEN
23713             IF(IDPDG1.EQ.22) THEN
23714 *             IF(MOD(ABS(IB),2).EQ.0) THEN
23715 *               SUM = SUM+PDF2(IB)*4.D0/9.D0
23716 *             ELSE
23717 *               SUM = SUM+PDF2(IB)*1.D0/9.D0
23718 *             ENDIF
23719               SUM = SUM+PDF2(IB)*Q_ch2(IB)
23720             ELSE
23721               SUM = SUM+PDF2(IB)
23722             ENDIF
23723             IF ( SUM.GE.SCHECK ) GOTO 720
23724           ENDIF
23725  710    CONTINUE
23726  720    CONTINUE
23727       ELSEIF ( MSPR.EQ.12 ) THEN
23728         IB     = 0
23729         DO 810 IA=-NF,NF
23730           IF ( IA.NE.0 ) THEN
23731             IF(IDPDG2.EQ.22) THEN
23732 *             IF(MOD(ABS(IA),2).EQ.0) THEN
23733 *               SUM = SUM+PDF1(IA)*4.D0/9.D0
23734 *             ELSE
23735 *               SUM = SUM+PDF1(IA)*1.D0/9.D0
23736 *             ENDIF
23737               SUM = SUM+PDF1(IA)*Q_ch2(IA)
23738             ELSE
23739               SUM = SUM+PDF1(IA)
23740             ENDIF
23741             IF ( SUM.GE.SCHECK ) GOTO 820
23742           ENDIF
23743  810    CONTINUE
23744  820    CONTINUE
23745       ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23746         IA     = 0
23747         IB     = 0
23748       ENDIF
23749 C  final check
23750       IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
23751         WRITE(LO,*) 'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23752         WRITE(LO,*) 'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
23753         GOTO 111
23754       ENDIF
23755 C
23756 C  find flavour of final partons
23757 C
23758       IC = IA
23759       ID = IB
23760       IF     ( MSPR.EQ.2 ) THEN
23761         IC = 0
23762         ID = 0
23763       ELSEIF ( MSPR.EQ.4 ) THEN
23764         IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23765         IF ( IC.GT.NF ) IC = NF-IC
23766         ID =-IC
23767       ELSEIF ( MSPR.EQ.6 ) THEN
23768         IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23769         IF ( IC.GT.NF-1 ) IC = NF-1-IC
23770         IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23771         ID =-IC
23772       ELSEIF ( MSPR.EQ.11) THEN
23773         SUM = 0.D0
23774         DO 730 IC=-NF,NF
23775           IF ( IC.NE.0 ) THEN
23776             IF(IDPDG1.EQ.22) THEN
23777 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23778 *               SUM = SUM + 4.D0
23779 *             ELSE
23780 *               SUM = SUM + 1.D0
23781 *             ENDIF
23782               SUM = SUM + Q_ch2(IC)
23783             ELSE
23784               SUM = SUM + 1.D0
23785             ENDIF
23786           ENDIF
23787  730    CONTINUE
23788         SCHECK = DT_RNDM(SUM)*SUM-EPS
23789         SUM = 0.D0
23790         DO 740 IC=-NF,NF
23791           IF ( IC.NE.0 ) THEN
23792             IF(IDPDG1.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             IF ( SUM.GE.SCHECK ) GOTO 750
23803           ENDIF
23804  740    CONTINUE
23805  750    CONTINUE
23806         ID = -IC
23807       ELSEIF ( MSPR.EQ.12) THEN
23808         IC = 0
23809         ID = IA
23810       ELSEIF ( MSPR.EQ.13) THEN
23811         SUM = 0.D0
23812         DO 830 IC=-NF,NF
23813           IF ( IC.NE.0 ) THEN
23814             IF(IDPDG2.EQ.22) THEN
23815 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23816 *               SUM = SUM + 4.D0
23817 *             ELSE
23818 *               SUM = SUM + 1.D0
23819 *             ENDIF
23820               SUM = SUM +  Q_ch2(IC)
23821             ELSE
23822               SUM = SUM + 1.D0
23823             ENDIF
23824           ENDIF
23825  830    CONTINUE
23826         SCHECK = DT_RNDM(SUM)*SUM-EPS
23827         SUM = 0.D0
23828         DO 840 IC=-NF,NF
23829           IF ( IC.NE.0 ) THEN
23830             IF(IDPDG2.EQ.22) THEN
23831 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23832 *               SUM = SUM + 4.D0
23833 *             ELSE
23834 *               SUM = SUM + 1.D0
23835 *             ENDIF
23836               SUM = SUM +  Q_ch2(IC)
23837             ELSE
23838               SUM = SUM + 1.D0
23839             ENDIF
23840             IF ( SUM.GE.SCHECK ) GOTO 850
23841           ENDIF
23842  840    CONTINUE
23843  850    CONTINUE
23844         ID = -IC
23845       ELSEIF ( MSPR.EQ.14) THEN
23846         SUM = 0.D0
23847         DO 930 IC=1,NF
23848           FAC1 = 1.D0
23849           FAC2 = 1.D0
23850           IF(MOD(ABS(IC),2).EQ.0) THEN
23851             IF(IDPDG1.EQ.22) FAC1 = 4.D0
23852             IF(IDPDG2.EQ.22) FAC2 = 4.D0
23853           ENDIF
23854           SUM = SUM + FAC1*FAC2
23855  930    CONTINUE
23856         IF(IPAMDL(64).NE.0) THEN
23857           IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
23858         ENDIF
23859         SCHECK = DT_RNDM(SUM)*SUM-EPS
23860         SUM = 0.D0
23861         DO 940 IC=1,NF
23862           FAC1 = 1.D0
23863           FAC2 = 1.D0
23864           IF(MOD(ABS(IC),2).EQ.0) THEN
23865             IF(IDPDG1.EQ.22) FAC1 = 4.D0
23866             IF(IDPDG2.EQ.22) FAC2 = 4.D0
23867           ENDIF
23868           SUM = SUM + FAC1*FAC2
23869           IF ( SUM.GE.SCHECK ) GOTO 950
23870  940    CONTINUE
23871         IC = 15
23872  950    CONTINUE
23873         ID = -IC
23874         IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
23875       ENDIF
23876       if(IC.eq.0) then
23877         XM3 = 0.D0
23878       else
23879         XM3 = PHO_PMASS(IC,3)
23880       endif
23881       if(ID.eq.0) then
23882         XM4 = 0.D0
23883       else
23884         XM4 = PHO_PMASS(ID,3)
23885       endif
23886       IF(ABS(IC).EQ.15) GOTO 955
23887
23888 C  valence quarks involved?
23889       IV1 = 0
23890       IF(IA.NE.0) THEN
23891         IF(IDPDG1.EQ.22) THEN
23892           CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
23893           IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
23894         ELSE
23895           IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
23896         ENDIF
23897       ENDIF
23898       IV2 = 0
23899       IF(IB.NE.0) THEN
23900         IF(IDPDG2.EQ.22) THEN
23901           CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
23902           IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
23903         ELSE
23904           IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
23905         ENDIF
23906       ENDIF
23907 C
23908 C  fill event record
23909 C
23910  955  CONTINUE
23911       CALL PHO_SFECFE(SINPHI,COSPHI)
23912       ECM2 = ECMP/2.D0
23913 C  incoming partons
23914       PHI1(1) = 0.D0
23915       PHI1(2) = 0.D0
23916       PHI1(3) = ECM2*X1
23917       PHI1(4) = PHI1(3)
23918       PHI1(5) = 0.D0
23919       PHI2(1) = 0.D0
23920       PHI2(2) = 0.D0
23921       PHI2(3) = -ECM2*X2
23922       PHI2(4) = -PHI2(3)
23923       PHI2(5) = 0.D0
23924 C  outgoing partons
23925       PHO1(1) = PT*COSPHI
23926       PHO1(2) = PT*SINPHI
23927       PHO1(3) = -ECM2*(U*X1-V*X2)
23928       PHO1(4) = -ECM2*(U*X1+V*X2)
23929       PHO1(5) = XM3
23930       PHO2(1) = -PHO1(1)
23931       PHO2(2) = -PHO1(2)
23932       PHO2(3) = -ECM2*(V*X1-U*X2)
23933       PHO2(4) = -ECM2*(V*X1+U*X2)
23934       PHO2(5) = XM4
23935
23936 C  convert to mass shell
23937       CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
23938       IF(IREJ.NE.0) THEN
23939         IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
23940      &    'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
23941      &    PT,XM3,XM4
23942         GOTO 111
23943       ENDIF
23944       PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
23945
23946 C  debug output
23947       IF(IDEB(78).GE.20) THEN
23948         SHAT = X1*X2*ECMP*ECMP
23949         WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
23950      &    MSPR,IA,IB,IC,ID
23951         WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
23952         WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
23953         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
23954         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
23955         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
23956         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
23957       ENDIF
23958
23959       END
23960
23961 *$ CREATE PHO_HARFAC.FOR
23962 *COPY PHO_HARFAC
23963 CDECK  ID>, PHO_HARFAC
23964       SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
23965 C*********************************************************************
23966 C
23967 C     initialization: find scaling factors and maxima of remaining
23968 C                     weights
23969 C
23970 C     input:   PTCUT  transverse momentum cutoff
23971 C              ECMI   cms energy
23972 C
23973 C     output:  Hfac(-1:Max_pro_2)  field for sampling hard processes
23974 C
23975 C*********************************************************************
23976       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23977       SAVE
23978
23979       PARAMETER ( MXABWT = 96 )
23980
23981 C  input/output channels
23982       INTEGER LI,LO
23983       COMMON /POINOU/ LI,LO
23984 C  data of c.m. system of Pomeron / Reggeon exchange
23985       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23986       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23987      &                 SIDP,CODP,SIFP,COFP
23988       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23989      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23990      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23991 C  some constants
23992       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23993       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23994      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23995 C  hard scattering parameters used for most recent hard interaction
23996       INTEGER NFbeta,NF
23997       DOUBLE PRECISION ALQCD2,BQCD
23998       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23999 C  integration precision for hard cross sections (obsolete)
24000       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24001       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24002 C  data on most recent hard scattering
24003       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24004       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24005      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24006      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24007       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24008      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24009      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24010      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24011      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24012 C  hard cross sections and MC selection weights
24013       INTEGER Max_pro_2
24014       PARAMETER ( Max_pro_2 = 16 )
24015       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24016      &  MH_acc_1,MH_acc_2
24017       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24018       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24019      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24020      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24021      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24022      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24023
24024       DIMENSION       ABSZ(MXABWT),WEIG(MXABWT)
24025       DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24026      &          F124(-1:Max_pro_2)
24027       DATA F124 / 1.D0,0.D0,
24028      &            4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24029      &            2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24030
24031       SS     = ECMI*ECMI
24032       AH     = (2.D0*PTCUT/ECMI)**2
24033       ALN    = LOG(AH)
24034       HLN    = LOG(0.5D0)
24035       NPOINT = NGAUIN
24036       CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24037       DO 10 M=-1,Max_pro_2
24038         S1(M) = 0.D0
24039 10    CONTINUE
24040
24041 C  resolved processes
24042       DO 80 I1=1,NPOINT
24043         Z1   = ABSZ(I1)
24044         X1   = EXP(ALN*Z1)
24045         DO 20 M=-1,9
24046           S2(M) = 0.D0
24047 20      CONTINUE
24048
24049         DO 60 I2=1,NPOINT
24050           Z2    = (1.D0-Z1)*ABSZ(I2)
24051           X2    = EXP(ALN*Z2)
24052           FAXX  = AH/(X1*X2)
24053           W     = SQRT(1.D0-FAXX)
24054           W1    = FAXX/(1.+W)
24055           WLOG  = LOG(W1)
24056           FWW   = FAXX*WLOG/W
24057           DO 30 M=-1,9
24058             S(M) = 0.D0
24059 30        CONTINUE
24060
24061           DO 40 I=1,NPOINT
24062             Z   = ABSZ(I)
24063             VA  =-0.5D0*W1/(W1+Z*W)
24064             UA  =-1.D0-VA
24065             VB  =-0.5D0*FAXX/(W1+2.D0*W*Z)
24066             UB  =-1.D0-VB
24067             VC  =-EXP(HLN+Z*WLOG)
24068             UC  =-1.D0-VC
24069             VE  =-0.5D0*(1.D0+W)+Z*W
24070             UE  =-1.D0-VE
24071             S(1)  = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24072      &           WEIG(I)
24073             S(2)  = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24074      &            WEIG(I)
24075             S(3)  = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24076             S(5)  = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24077      &            (8./27.)*UA*UA*VA)*WEIG(I)
24078             S(6)  = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24079             S(7)  = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24080      &            (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24081             S(8)  = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24082             S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
24083 40        CONTINUE
24084           S(4)    = S(2)*(9./32.)
24085           DO 50 M=-1,8
24086             S2(M) = S2(M)+S(M)*WEIG(I2)*W
24087 50        CONTINUE
24088 60      CONTINUE
24089         DO 70 M=-1,8
24090           S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
24091 70      CONTINUE
24092 80    CONTINUE
24093       S1(4) = S1(4)*NF
24094       S1(6) = S1(6)*MAX(0,NF-1)
24095 C
24096 C  direct processes
24097       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24098      &   .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24099         DO 180 I1=1,NPOINT
24100           Z2   = ABSZ(I1)
24101           X2   = EXP(ALN*Z2)
24102           FAXX  = AH/X2
24103           W     = SQRT(1.D0-FAXX)
24104           W1    = FAXX/(1.D0+W)
24105           WLOG  = LOG(W1)
24106           WL = LOG(FAXX/(1.D0+W)**2)
24107           FWW1  = FAXX*WL/ALN
24108           FWW2  = FAXX*WLOG/ALN
24109           DO 130 M=10,12
24110             S(M) = 0.D0
24111  130      CONTINUE
24112 C
24113           DO 140 I=1,NPOINT
24114             Z   = ABSZ(I)
24115             UA  =-(1.D0+W)/2.D0*EXP(Z*WL)
24116             VA  =-1.D0-UA
24117             VB  =-EXP(HLN+Z*WLOG)
24118             UB  =-1.D0-VB
24119             S(10)  = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24120             S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24121  140      CONTINUE
24122           DO 170 M=10,11
24123             S1(M) = S1(M)+S(M)*WEIG(I1)
24124  170      CONTINUE
24125  180    CONTINUE
24126         S1(12) = S1(10)
24127         S1(13) = S1(11)
24128 C  quark charges fractions
24129         IF(IDPDG1.EQ.22) THEN
24130           CHRNF = 0.D0
24131           DO 100 I=1,NF
24132             CHRNF = CHRNF + Q_ch2(I)
24133  100      CONTINUE
24134           S1(11) = S1(11)*CHRNF
24135         ELSE IF(IDPDG1.EQ.990) THEN
24136           S1(11) = S1(11)*NF
24137         ELSE
24138           S1(11) = 0.D0
24139         ENDIF
24140         IF(IDPDG2.EQ.22) THEN
24141           CHRNF = 0.D0
24142           DO 200 I=1,NF
24143             CHRNF = CHRNF + Q_ch2(I)
24144  200      CONTINUE
24145           S1(13) = S1(13)*CHRNF
24146         ELSE IF(IDPDG2.EQ.990) THEN
24147           S1(13) = S1(13)*NF
24148         ELSE
24149           S1(13) = 0.D0
24150         ENDIF
24151       ENDIF
24152 C
24153 C  global factors
24154       FFF    = PI*GEV2MB*ALN*ALN/(AH*SS)
24155       DO 90 M=-1,Max_pro_2
24156         Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
24157 90    CONTINUE
24158 C
24159 C  double direct process
24160       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24161      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24162         FAC = 0.D0
24163         DO 300 I=1,NF
24164           IF(IDPDG1.EQ.22) THEN
24165             F1 = Q_ch2(I)
24166           ELSE
24167             F1 = 1.D0
24168           ENDIF
24169           IF(IDPDG2.EQ.22) THEN
24170             F2 = Q_ch2(I)
24171           ELSE
24172             F2 = 1.D0
24173           ENDIF
24174           FAC = FAC+F1*F2*3.D0
24175  300    CONTINUE
24176         ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24177         Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24178      &               *GEV2MB*FAC
24179       ENDIF
24180       END
24181
24182 *$ CREATE PHO_HARWGX.FOR
24183 *COPY PHO_HARWGX
24184 CDECK  ID>, PHO_HARWGX
24185       SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24186 C**********************************************************************
24187 C
24188 C     find maximum of remaining weight for MC sampling
24189 C
24190 C     input:   PTCUT  transverse momentum cutoff
24191 C              ECM    cms energy
24192 C
24193 C     output:  HWgx(-1:Max_pro_2)  field for sampling hard processes
24194 C
24195 C**********************************************************************
24196       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24197       SAVE
24198
24199       PARAMETER ( NKM = 10 )
24200       PARAMETER ( TINY = 1.D-20 )
24201
24202 C  input/output channels
24203       INTEGER LI,LO
24204       COMMON /POINOU/ LI,LO
24205 C  event debugging information
24206       INTEGER NMAXD
24207       PARAMETER (NMAXD=100)
24208       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24209      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24210       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24211      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24212 C  data on most recent hard scattering
24213       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24214       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24215      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24216      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24217       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24218      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24219      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24220      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24221      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24222 C  hard cross sections and MC selection weights
24223       INTEGER Max_pro_2
24224       PARAMETER ( Max_pro_2 = 16 )
24225       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24226      &  MH_acc_1,MH_acc_2
24227       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24228       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24229      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24230      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24231      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24232      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24233
24234       DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24235      &  XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24236       DIMENSION IFTAB(-1:Max_pro_2)
24237       DATA IFTAB  / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24238
24239 C  initial settings
24240       AH    = (2.D0*PTCUT/ECM)**2
24241       ALNH  = LOG(AH)
24242       FF(0) = 0.D0
24243       DO 22 I=1,NKM
24244         FF(I) = 0.D0
24245         XM1(I) = 0.D0
24246         XM2(I) = 0.D0
24247         PTM(I) = 0.D0
24248         ZMX(1,I) = 0.D0
24249         ZMX(2,I) = 0.D0
24250         ZMX(3,I) = 0.D0
24251         DMX(1,I) = 0.D0
24252         DMX(2,I) = 0.D0
24253         DMX(3,I) = 0.D0
24254         IMX(I) = 0
24255         IPO(I) = 0
24256  22   CONTINUE
24257
24258       NKML = 10
24259       DO 40 NKON=1,NKML
24260
24261         DO 50 IST=1,3
24262 C  start configuration
24263         IF(IST.EQ.1) THEN
24264           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24265           Z(2) = 0.5
24266           Z(3) = 0.1
24267           D(1) =-0.5
24268           D(2) = 0.5
24269           D(3) = 0.5
24270         ELSE IF(IST.EQ.2) THEN
24271           Z(1) = 0.999D0
24272           Z(2) = 0.5
24273           Z(3) = 0.0
24274           D(1) =-0.5
24275           D(2) = 0.5
24276           D(3) = 0.5
24277         ELSE IF(IST.EQ.3) THEN
24278           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24279           Z(2) = 0.1
24280           Z(3) = 0.1
24281           D(1) =-0.5
24282           D(2) = 0.5
24283           D(3) = 0.5
24284         ELSE IF(IST.EQ.4) THEN
24285           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24286           Z(2) = 0.9
24287           Z(3) = 0.1
24288           D(1) =-0.5
24289           D(2) = 0.5
24290           D(3) = 0.5
24291         ENDIF
24292         IT   = 0
24293         CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24294 C  process possible?
24295         IF(F2.LE.0.D0) GOTO 35
24296
24297  10     CONTINUE
24298           IT   = IT+1
24299           FOLD = F2
24300           DO 30 I=1,3
24301             D(I) = D(I)/5.D0
24302             Z(I)   = Z(I)+D(I)
24303             CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24304             IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24305             IF ( F2.GT.F3 ) D(I) =-D(I)
24306  20         CONTINUE
24307               F1   = MIN(F2,F3)
24308               F2   = MAX(F2,F3)
24309               Z(I) = Z(I)+D(I)
24310               CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24311             IF ( F3.GT.F2 ) GOTO 20
24312             ZZ     = Z(I)-D(I)
24313             Z(I)   = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24314             IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24315      &        CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24316             IF ( F1.LE.F2 ) Z(I) = ZZ
24317             F2     = MAX(F1,F2)
24318  30       CONTINUE
24319         IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24320
24321         IF(F2.GT.FF(NKON)) THEN
24322           FF(NKON)  = MAX(F2,0.D0)
24323           XM1(NKON) = X1
24324           XM2(NKON) = X2
24325           PTM(NKON) = PT
24326           ZMX(1,NKON) = Z(1)
24327           ZMX(2,NKON) = Z(2)
24328           ZMX(3,NKON) = Z(3)
24329           DMX(1,NKON) = D(1)
24330           DMX(2,NKON) = D(2)
24331           DMX(3,NKON) = D(3)
24332           IMX(NKON) = IT
24333           IPO(NKON) = IST
24334         ENDIF
24335 C
24336  50     CONTINUE
24337  35     CONTINUE
24338  40   CONTINUE
24339
24340 C  debug output
24341       IF(IDEB(38).GE.5) THEN
24342         WRITE(LO,'(/1X,A)')
24343      &    'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24344         DO 60 I=1,NKM
24345           IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24346      &      IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24347      &      DMX(2,I),DMX(3,I)
24348  60     CONTINUE
24349       ENDIF
24350
24351       DO 70 I=-1,Max_pro_2
24352         HWgx(I)  = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24353  70   CONTINUE
24354
24355 C  debug output
24356       IF(IDEB(38).GE.5) THEN
24357         WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24358         WRITE(LO,'(5X,A)') 'I    X1   X2   PT   HWgx(I)  FDIS'
24359         DO 80 I=-1,Max_pro_2
24360           IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24361             MSPR = I
24362             X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24363             X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24364             PT = PTM(IFTAB(I))
24365             CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24366             WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24367           ENDIF
24368  80     CONTINUE
24369       ENDIF
24370
24371       END
24372
24373 *$ CREATE PHO_HARWGI.FOR
24374 *COPY PHO_HARWGI
24375 CDECK  ID>, PHO_HARWGI
24376       SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24377 C**********************************************************************
24378 C
24379 C     auxiliary subroutine to find maximum of remaining weight
24380 C
24381 C     input:  ECMX   current CMS energy
24382 C             PTCUT  current pt cutoff
24383 C             NKON   process label  1..5  resolved
24384 C                                   6..7  direct particle 1
24385 C                                   8..9  direct particle 2
24386 C                                   10    double direct
24387 C             Z(3)   transformed variable
24388 C
24389 C     output: remaining weight
24390 C
24391 C**********************************************************************
24392       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24393       SAVE
24394
24395       DIMENSION Z(3)
24396
24397       PARAMETER ( NKM   = 10 )
24398       PARAMETER ( TINY  = 1.D-30,
24399      &            TINY6 = 1.D-06 )
24400
24401 C  input/output channels
24402       INTEGER LI,LO
24403       COMMON /POINOU/ LI,LO
24404 C  event debugging information
24405       INTEGER NMAXD
24406       PARAMETER (NMAXD=100)
24407       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24408      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24409       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24410      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24411 C  model switches and parameters
24412       CHARACTER*8 MDLNA
24413       INTEGER ISWMDL,IPAMDL
24414       DOUBLE PRECISION PARMDL
24415       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24416 C  data of c.m. system of Pomeron / Reggeon exchange
24417       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24418       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24419      &                 SIDP,CODP,SIFP,COFP
24420       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24421      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
24422      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
24423 C  currently activated parton density parametrizations
24424       CHARACTER*8 PDFNAM
24425       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24426       DOUBLE PRECISION PDFLAM,PDFQ2M
24427       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24428      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24429 C  hard scattering parameters used for most recent hard interaction
24430       INTEGER NFbeta,NF
24431       DOUBLE PRECISION ALQCD2,BQCD
24432       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24433 C  some hadron information, will be deleted in future versions
24434       INTEGER NFS
24435       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24436       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24437 C  scale parameters for parton model calculations
24438       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24439       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24440       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24441      &                NQQAL,NQQALI,NQQALF,NQQPD
24442 C  data on most recent hard scattering
24443       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24444       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24445      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24446      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24447       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24448      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24449      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24450      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24451      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24452
24453       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24454       DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24455
24456       FDIS = 0.D0
24457
24458       IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24459      &  'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24460 C  check input values
24461       IF ( Z(1).LT.0.D0  .OR.  Z(1).GT.1.D0 ) RETURN
24462       IF ( Z(2).LT.0.D0  .OR.  Z(2).GT.1.D0 ) RETURN
24463       IF ( Z(3).LT.0.D0  .OR.  Z(3).GT.1.D0 ) RETURN
24464 C  transformations
24465       Y1    = EXP(ALNH*Z(1))
24466       IF(NKON.LE.5) THEN
24467 C  resolved kinematic
24468         Y2  =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24469         X1  = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24470         X2  = X1-Y2
24471         X1 = MIN(X1,0.999999999999D0)
24472         X2 = MIN(X2,0.999999999999D0)
24473       ELSE IF(NKON.LE.7) THEN
24474 C  direct kinematic 1
24475         X1 = 1.D0
24476         X2 = MIN(Y1,0.999999999999D0)
24477       ELSE IF(NKON.LE.9) THEN
24478 C  direct kinematic 2
24479         X1 = MIN(Y1,0.999999999999D0)
24480         X2 = 1.D0
24481       ELSE
24482 C  double direct kinematic
24483         X1 = 1.D0
24484         X2 = 1.D0
24485       ENDIF
24486       W   = SQRT(MAX(TINY,1.D0-AH/Y1))
24487       V   =-0.5D0+W*(Z(3)-0.5D0)
24488       U   =-(1.D0+V)
24489       PT  = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24490
24491 C  set hard scale  QQ  for alpha and partondistr.
24492       IF     ( NQQAL.EQ.1 ) THEN
24493         QQAL = AQQAL*PT*PT
24494       ELSEIF ( NQQAL.EQ.2 ) THEN
24495         QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24496       ELSEIF ( NQQAL.EQ.3 ) THEN
24497         QQAL = AQQAL*Y1*ECMX*ECMX
24498       ELSEIF ( NQQAL.EQ.4 ) THEN
24499         QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24500       ENDIF
24501       IF     ( NQQPD.EQ.1 ) THEN
24502         QQPD = AQQPD*PT*PT
24503       ELSEIF ( NQQPD.EQ.2 ) THEN
24504         QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24505       ELSEIF ( NQQPD.EQ.3 ) THEN
24506         QQPD = AQQPD*Y1*ECMX*ECMX
24507       ELSEIF ( NQQPD.EQ.4 ) THEN
24508         QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24509       ENDIF
24510 C
24511       IF(NKON.LE.5) THEN
24512         DO 10 N=1,5
24513           F(N) = 0.D0
24514  10     CONTINUE
24515 C  resolved processes
24516         ALPHA1 = PHO_ALPHAS(QQAL,3)
24517         ALPHA2 = ALPHA1
24518         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24519         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24520 C  calculate full distribution FDIS
24521         DO 20 I=1,NF
24522           F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24523           F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24524           F(4) = F(4)+PDA(I)+PDA(-I)
24525           F(5) = F(5)+PDB(I)+PDB(-I)
24526 20      CONTINUE
24527         F(1)   = PDA(0)*PDB(0)
24528         T      = PDA(0)*F(5)+PDB(0)*F(4)
24529         F(5)   = F(4)*F(5)-(F(2)+F(3))
24530         F(4)   = T
24531       ELSE IF(NKON.LE.7) THEN
24532 C  direct processes particle 1
24533         IF(IDPDG1.EQ.22) THEN
24534           ALPHA1 = pho_alphae(QQAL)
24535           CH1 = 4.D0/9.D0
24536           CH2 = 3.D0/9.D0
24537         ELSE IF(IDPDG1.EQ.990) THEN
24538           ALPHA1 = PARMDL(74)
24539           CH1 = 1.D0
24540           CH2 = 0.D0
24541         ELSE
24542           FDIS = -1.D0
24543           RETURN
24544         ENDIF
24545         ALPHA2 = PHO_ALPHAS(QQAL,2)
24546         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24547         F(6) = 0.D0
24548         DO 30 I=1,NF
24549           F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24550  30     CONTINUE
24551         F(7)   = PDB(0)
24552       ELSE IF(NKON.LE.9) THEN
24553 C  direct processes particle 2
24554         ALPHA1 = PHO_ALPHAS(QQAL,1)
24555         IF(IDPDG2.EQ.22) THEN
24556           ALPHA2 = pho_alphae(QQAL)
24557           CH1 = 4.D0/9.D0
24558           CH2 = 3.D0/9.D0
24559         ELSE IF(IDPDG2.EQ.990) THEN
24560           ALPHA2 = PARMDL(74)
24561           CH1 = 1.D0
24562           CH2 = 0.D0
24563         ELSE
24564           FDIS = -1.D0
24565           RETURN
24566         ENDIF
24567         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24568         F(8) = 0.D0
24569         DO 40 I=1,NF
24570           F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24571  40     CONTINUE
24572         F(9)   = PDA(0)
24573       ELSE
24574 C  double direct process
24575         SSR = ECMX*ECMX
24576         IF(IDPDG1.EQ.22) THEN
24577           ALPHA1 = pho_alphae(SSR)
24578         ELSE IF(IDPDG1.EQ.990) THEN
24579           ALPHA1 = PARMDL(74)
24580         ELSE
24581           FDIS = -1.D0
24582           RETURN
24583         ENDIF
24584         IF(IDPDG2.EQ.22) THEN
24585           ALPHA2 = pho_alphae(SSR)
24586         ELSE IF(IDPDG2.EQ.990) THEN
24587           ALPHA2 = PARMDL(74)
24588         ELSE
24589           FDIS = -1.D0
24590           RETURN
24591         ENDIF
24592         F(10) = 1.D0
24593       ENDIF
24594
24595       FDIS   = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24596
24597 C  debug output
24598       IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24599      &  'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24600      &  NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24601
24602       END
24603
24604 *$ CREATE PHO_HARINI.FOR
24605 *COPY PHO_HARINI
24606 CDECK  ID>, PHO_HARINI
24607       SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24608 C**********************************************************************
24609 C
24610 C     initialize calculation of hard cross section
24611 C
24612 C     must not be called during MC generation
24613 C
24614 C***********************************************************************
24615       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24616       SAVE
24617
24618       PARAMETER ( DEPS   = 1.D-10 )
24619
24620 C  input/output channels
24621       INTEGER LI,LO
24622       COMMON /POINOU/ LI,LO
24623 C  event debugging information
24624       INTEGER NMAXD
24625       PARAMETER (NMAXD=100)
24626       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24627      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24628       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24629      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24630 C  model switches and parameters
24631       CHARACTER*8 MDLNA
24632       INTEGER ISWMDL,IPAMDL
24633       DOUBLE PRECISION PARMDL
24634       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24635 C  currently activated parton density parametrizations
24636       CHARACTER*8 PDFNAM
24637       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24638       DOUBLE PRECISION PDFLAM,PDFQ2M
24639       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24640      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24641 C  some constants
24642       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24643       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24644      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24645 C  scale parameters for parton model calculations
24646       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24647       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24648       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24649      &                NQQAL,NQQALI,NQQALF,NQQPD
24650 C  data of c.m. system of Pomeron / Reggeon exchange
24651       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24652       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24653      &                 SIDP,CODP,SIFP,COFP
24654       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24655      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
24656      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
24657 C  obsolete cut-off information
24658       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24659       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24660 C  hard scattering parameters used for most recent hard interaction
24661       INTEGER NFbeta,NF
24662       DOUBLE PRECISION ALQCD2,BQCD
24663       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24664
24665       double precision pho_alphas
24666
24667       CHARACTER*20 RFLAG
24668
24669 C  set local Pomeron c.m. system data
24670       IDPDG1    = IDP1
24671       IDPDG2    = IDP2
24672       PVIRTP(1) = PV1
24673       PVIRTP(2) = PV2
24674 C  initialize PDFs
24675       CALL PHO_ACTPDF(IDPDG1,1)
24676       CALL PHO_ACTPDF(IDPDG2,2)
24677 C  initialize alpha_s calculation
24678       DUMMY = PHO_ALPHAS(0.D0,-4)
24679 C  initialize scales with defaults
24680       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24681         IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24682           AQQAL  = PARMDL(83)
24683           AQQALI = PARMDL(86)
24684           AQQALF = PARMDL(89)
24685           AQQPD  = PARMDL(92)
24686           NQQAL  = IPAMDL(83)
24687           NQQALI = IPAMDL(86)
24688           NQQALF = IPAMDL(89)
24689           NQQPD  = IPAMDL(92)
24690         ELSE
24691           AQQAL  = PARMDL(82)
24692           AQQALI = PARMDL(85)
24693           AQQALF = PARMDL(88)
24694           AQQPD  = PARMDL(91)
24695           NQQAL  = IPAMDL(82)
24696           NQQALI = IPAMDL(85)
24697           NQQALF = IPAMDL(88)
24698           NQQPD  = IPAMDL(91)
24699         ENDIF
24700       ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24701         AQQAL  = PARMDL(82)
24702         AQQALI = PARMDL(85)
24703         AQQALF = PARMDL(88)
24704         AQQPD  = PARMDL(91)
24705         NQQAL  = IPAMDL(82)
24706         NQQALI = IPAMDL(85)
24707         NQQALF = IPAMDL(88)
24708         NQQPD  = IPAMDL(91)
24709       ELSE
24710         AQQAL  = PARMDL(81)
24711         AQQALI = PARMDL(84)
24712         AQQALF = PARMDL(87)
24713         AQQPD  = PARMDL(90)
24714         NQQAL  = IPAMDL(81)
24715         NQQALI = IPAMDL(84)
24716         NQQALF = IPAMDL(87)
24717         NQQPD  = IPAMDL(90)
24718       ENDIF
24719       IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24720       IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24721       IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24722       IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24723       IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24724       IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24725       IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24726       IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24727       AQQAL  = PARMDL(109+IP)
24728       AQQALI = PARMDL(113+IP)
24729       AQQALF = PARMDL(117+IP)
24730       AQQPD  = PARMDL(121+IP)
24731       NQQAL  = IPAMDL(64+IP)
24732       NQQALI = IPAMDL(68+IP)
24733       NQQALF = IPAMDL(72+IP)
24734       NQQPD  = IPAMDL(76+IP)
24735       PTCUT(1) = PARMDL(36)
24736       PTCUT(2) = PARMDL(37)
24737       PTCUT(3) = PARMDL(38)
24738       PTCUT(4) = PARMDL(39)
24739       PTANO(1) = PARMDL(130)
24740       PTANO(2) = PARMDL(131)
24741       PTANO(3) = PARMDL(132)
24742       PTANO(4) = PARMDL(133)
24743       RFLAG = '(energy-independent)'
24744       IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24745
24746 C  write out all settings
24747       IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24748         WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24749      &    PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24750      &    PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24751      &    PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
24752 1050    FORMAT(/,
24753      &    ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24754      &    5X,'particle 1 / particle 2:',2I8,/,
24755      &    5X,'min. PT   :',F7.1,2X,A,/,
24756      &    5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24757      &    5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24758      &    5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24759      &    5X,'max. number of active flavours NF  :',I3,/,
24760      &    5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24761       ENDIF
24762
24763       END
24764
24765 *$ CREATE PHO_HARINT.FOR
24766 *COPY PHO_HARINT
24767 CDECK  ID>, PHO_HARINT
24768       SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24769 C**********************************************************************
24770 C
24771 C     interpolate cross sections and weights for hard scattering
24772 C
24773 C     input:  IPP    particle combination (neg. for add. user cuts)
24774 C             ECM    CMS energy (GeV)
24775 C             P2V1/2 particle virtualities (pos., GeV**2)
24776 C             I1     first subprocess to calculate
24777 C             I2     last subprocess to calculate
24778 C                    <-1  only scales and cutoffs calculated
24779 C             K1     first variable to calculate
24780 C             K2     last variable to calculate
24781 C             MSPOM  cross sections to use for pt distribution
24782 C                    0  reggeon
24783 C                    >0 pomeron
24784 C
24785 C             for K1 < 3 the soft pt distribution is also calculated
24786 C
24787 C     output: interpolated values in HWgx, HSig, Hdpt
24788 C
24789 C***********************************************************************
24790       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24791       SAVE
24792
24793       PARAMETER ( DEPS   = 1.D-15,
24794      &            DEPS2  = 2.D-15 )
24795
24796 C  input/output channels
24797       INTEGER LI,LO
24798       COMMON /POINOU/ LI,LO
24799 C  event debugging information
24800       INTEGER NMAXD
24801       PARAMETER (NMAXD=100)
24802       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24803      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24804       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24805      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24806 C  model switches and parameters
24807       CHARACTER*8 MDLNA
24808       INTEGER ISWMDL,IPAMDL
24809       DOUBLE PRECISION PARMDL
24810       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24811 C  Reggeon phenomenology parameters
24812       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
24813      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
24814       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
24815      &                ALREG,ALREGP,GR(2),B0REG(2),
24816      &                GPPP,GPPR,B0PPP,B0PPR,
24817      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
24818 C  parameters of 2x2 channel model
24819       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
24820       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
24821 C  data needed for soft-pt calculation
24822       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
24823       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
24824 C  scale parameters for parton model calculations
24825       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24826       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24827       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24828      &                NQQAL,NQQALI,NQQALF,NQQPD
24829 C  obsolete cut-off information
24830       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24831       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24832 C  event weights and generated cross section
24833       INTEGER IPOWGC,ISWCUT,IVWGHT
24834       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
24835       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
24836      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
24837 C  parameters for DGLAP backward evolution in ISR
24838       INTEGER NFSISR
24839       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
24840       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
24841 C  hard cross sections and MC selection weights
24842       INTEGER Max_pro_2
24843       PARAMETER ( Max_pro_2 = 16 )
24844       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24845      &  MH_acc_1,MH_acc_2
24846       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24847       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24848      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24849      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24850      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24851      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24852 C  interpolation tables for hard cross section and MC selection weights
24853       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
24854       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
24855       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
24856       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
24857      &  HQ2a_tab,HQ2b_tab,HEcm_tab
24858       COMMON /POHTAB/
24859      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24860      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24861      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24862      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24863      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
24864      &  HEcm_tab(1:Max_tab_E,0:4),
24865      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
24866 C  data on most recent hard scattering
24867       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24868       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24869      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24870      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24871       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24872      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24873      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24874      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24875      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24876 C  energy-interpolation table
24877       INTEGER IEETA2
24878       PARAMETER ( IEETA2 = 20 )
24879       INTEGER ISIMAX
24880       DOUBLE PRECISION SIGTAB,SIGECM
24881       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
24882
24883       DOUBLE PRECISION XP,PTS
24884       DIMENSION XP(2),PTS(0:2,2)
24885
24886       INTEGER IV
24887       DIMENSION IV(2)
24888
24889       IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
24890      &    'PHO_HARINT: called with ',
24891      &    'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
24892      &    IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
24893
24894       IP = ABS(IPP)
24895       IF(IPP.GT.0) THEN
24896 C  default minimum bias cutoff
24897         PTCUT(IP) = pho_ptcut(ECM,IP)
24898       ELSE
24899 C  user defined additional cutoff
24900         PTCUT(IP) = HSWCUT(4+IP)
24901       ENDIF
24902       PTWANT = PTCUT(IP)
24903
24904 C  ISR cutoffs
24905       Q2CUT     = MIN(PTWANT**2,PARMDL(125+IP))
24906       Q2MISR(1) = MAX(P2V1,Q2CUT)
24907       Q2MISR(2) = MAX(P2V2,Q2CUT)
24908 C  cutoff for direct photon contribution to photon PDF
24909       PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
24910       PTA1      = PTANO(IP)
24911 C  scales for hard scattering
24912       AQQAL  = PARMDL(109+IP)
24913       AQQALI = PARMDL(113+IP)
24914       AQQALF = PARMDL(117+IP)
24915       AQQPD  = PARMDL(121+IP)
24916       NQQAL  = IPAMDL(64+IP)
24917       NQQALI = IPAMDL(68+IP)
24918       NQQALF = IPAMDL(72+IP)
24919       NQQPD  = IPAMDL(76+IP)
24920       IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
24921      &  'PHO_HARINT: scales:',
24922      &  NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
24923
24924       IF(I2.LT.-1) RETURN
24925
24926       IL = IP
24927       IF(IPP.LT.0) IL = 0
24928
24929 C  double-log interpolation
24930       IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
24931         DO 50 M=I1,I2
24932           Hfac(M) = 0.D0
24933           HWgx(M) = 0.D0
24934           HSig(M) = 0.D0
24935           Hdpt(M) = 0.D0
24936  50     CONTINUE
24937       ELSE
24938         I=1
24939  310    CONTINUE
24940           I = I+1
24941         IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
24942
24943         Ia = 1
24944         Ib = 1
24945         fac = LOG(ECM/HEcm_tab(I-1,IL))
24946      &       /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
24947         do M=I1,I2
24948 C  factor due to phase space integration
24949           XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24950      &      *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
24951      &           /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
24952           XX = EXP(XX)
24953           IF(XX.LT.DEPS2) XX = 0.D0
24954           Hfac(M) = XX
24955 C  max. weight
24956           XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24957      &      *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
24958      &           /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
24959           XX = EXP(XX)
24960           IF(XX.LT.DEPS2) XX = 0.D0
24961           HWgx(M) = XX*1.2D0
24962 C  hard cross section
24963           XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24964      &      *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
24965      &           /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
24966           XX = EXP(XX)
24967           IF(XX.LT.DEPS2) XX = 0.D0
24968           HSig(M) = XX
24969 C  differential hard cross section
24970           XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24971      &      *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
24972      &           /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
24973           XX = EXP(XX)
24974           IF(XX.LT.DEPS2) XX = 0.D0
24975           Hdpt(M) = XX
24976         enddo
24977       ENDIF
24978
24979       IF((K1.LT.3).AND.(K2.GE.3)) THEN
24980 C  cross check
24981         IF((I1.GT.9).OR.(I2.LT.9)) THEN
24982           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
24983      &      'hard cross section not calculated ',I1,I2
24984         ENDIF
24985         SIGH   = HSig(9)
24986         DSIGHP = Hdpt(9)
24987 C  load soft cross sections from interpolation table
24988         IF(ECM.LE.SIGECM(IP,1)) THEN
24989           L1 = 1
24990           L2 = 1
24991         ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
24992           DO 55 I=2,ISIMAX
24993             IF(ECM.LE.SIGECM(IP,I)) GOTO 205
24994  55       CONTINUE
24995  205      CONTINUE
24996           L1 = I-1
24997           L2 = I
24998         ELSE
24999           WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
25000      &      'PHO_HARINT: energy too high (IP,Ecm,Emax)',
25001      &      IP,ECM,SIGECM(IP,ISIMAX)
25002           CALL PHO_PREVNT(-1)
25003           L1 = ISIMAX-1
25004           L2 = ISIMAX
25005         ENDIF
25006         FAC2=0.D0
25007         IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
25008      &                    /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
25009         FAC1=1.D0-FAC2
25010         SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
25011      &         FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
25012
25013         FS = FPS(IP)
25014         FH = FPH(IP)
25015         CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
25016       ENDIF
25017
25018  300  CONTINUE
25019
25020 C  debug output
25021       IF(IDEB(58).GE.15) THEN
25022         WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25023      &    'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25024      &    KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25025         DO 162 M=I1,I2
25026           WRITE(LO,'(5X,2I3,1p,4E12.3)')
25027      &      M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25028  162    CONTINUE
25029       ENDIF
25030
25031       END
25032
25033 *$ CREATE PHO_PTCUT.FOR
25034 *COPY PHO_PTCUT
25035       DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25036 C***********************************************************************
25037 C
25038 C     calculate energy-dependent transverse momentum cutoff
25039 C
25040 C***********************************************************************
25041       IMPLICIT NONE
25042       SAVE
25043
25044       double precision ECM
25045       integer IP
25046
25047 C  input/output channels
25048       INTEGER LI,LO
25049       COMMON /POINOU/ LI,LO
25050 C  event debugging information
25051       INTEGER NMAXD
25052       PARAMETER (NMAXD=100)
25053       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25054      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25055       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25056      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25057 C  model switches and parameters
25058       CHARACTER*8 MDLNA
25059       INTEGER ISWMDL,IPAMDL
25060       DOUBLE PRECISION PARMDL
25061       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25062
25063       pho_ptcut = PARMDL(35+IP)
25064
25065       IF(IPAMDL(7).EQ.1) THEN
25066 C  Bopp et al. type (DPMJET)
25067         pho_ptcut = PARMDL(35+IP)
25068      &             + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25069       ELSE IF(IPAMDL(7).EQ.2) THEN
25070 C  Gribov-Levin-Ryskin type
25071         pho_ptcut = PARMDL(35+IP)
25072      &             + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25073       ENDIF
25074
25075       END
25076
25077 *$ CREATE PHO_HARMCI.FOR
25078 *COPY PHO_HARMCI
25079 CDECK  ID>, PHO_HARMCI
25080       SUBROUTINE PHO_HARMCI(IP,EMAXF)
25081 C**********************************************************************
25082 C
25083 C     initialize MC sampling and calculate hard cross section
25084 C
25085 C     input:  IP       particle combination (neg. number for user cut)
25086 C             EMAXF    maximum CMS energy for
25087 C                      interpolation table in reference to PTCUT(1..4)
25088 C
25089 C***********************************************************************
25090       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25091       SAVE
25092
25093       PARAMETER (DEPS   = 1.D-10,
25094      &           PLARGE = 1.D20 )
25095
25096 C  input/output channels
25097       INTEGER LI,LO
25098       COMMON /POINOU/ LI,LO
25099 C  event debugging information
25100       INTEGER NMAXD
25101       PARAMETER (NMAXD=100)
25102       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25103      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25104       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25105      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25106 C  some constants
25107       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25108       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25109      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25110 C  global event kinematics and particle IDs
25111       INTEGER IFPAP,IFPAB
25112       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25113       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25114 C  data of c.m. system of Pomeron / Reggeon exchange
25115       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25116       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25117      &                 SIDP,CODP,SIFP,COFP
25118       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25119      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25120      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25121 C  model switches and parameters
25122       CHARACTER*8 MDLNA
25123       INTEGER ISWMDL,IPAMDL
25124       DOUBLE PRECISION PARMDL
25125       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25126 C  obsolete cut-off information
25127       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25128       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25129 C  scale parameters for parton model calculations
25130       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25131       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25132       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25133      &                NQQAL,NQQALI,NQQALF,NQQPD
25134 C  names of hard scattering processes
25135       INTEGER Max_pro_1
25136       PARAMETER ( Max_pro_1 = 16 )
25137       CHARACTER*18 PROC
25138       COMMON /POHPRO/ PROC(0:Max_pro_1)
25139 C  hard cross sections and MC selection weights
25140       INTEGER Max_pro_2
25141       PARAMETER ( Max_pro_2 = 16 )
25142       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25143      &  MH_acc_1,MH_acc_2
25144       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25145       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25146      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25147      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25148      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25149      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25150 C  interpolation tables for hard cross section and MC selection weights
25151       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25152       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25153       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25154       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25155      &  HQ2a_tab,HQ2b_tab,HEcm_tab
25156       COMMON /POHTAB/
25157      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25158      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25159      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25160      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25161      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25162      &  HEcm_tab(1:Max_tab_E,0:4),
25163      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25164 C  event weights and generated cross section
25165       INTEGER IPOWGC,ISWCUT,IVWGHT
25166       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25167       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25168      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25169
25170       COMPLEX*16 DSIG
25171       DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25172
25173 C  initialization for all pt cutoffs
25174       I = ABS(IP)
25175       IL = I
25176       IF(IP.LT.0) THEN
25177         IL = 0
25178         PTC = HSWCUT(4+I)
25179       else
25180         PTC = pho_ptcut(parmdl(19),I)
25181       ENDIF
25182
25183 C  skip unassigned PTCUT
25184       IF(PTC.LT.0.5D0) GOTO 1000
25185
25186       IH_Q2a_up(I) = 1
25187       IH_Q2b_up(I) = 1
25188       do ib=1,Max_tab_Q2
25189         do ia=1,Max_tab_Q2
25190           do ie=1,Max_tab_E
25191             do m=-1,Max_pro_2
25192               Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25193               HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25194               HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25195               Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25196             enddo
25197           enddo
25198         enddo
25199       enddo
25200
25201       ELLOW = LOG(2.05*PTC)
25202       DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25203 C  energy too low
25204       IF(DELTA.LE.0.D0) GOTO 1000
25205
25206 C  switch between external particles and Pomeron
25207       IF(I.EQ.4) THEN
25208         IDP1 = 990
25209         PV1  = 0.D0
25210         IDP2 = 990
25211         PV2  = 0.D0
25212       ELSE IF(I.EQ.3) THEN
25213         IDP1 = IFPAP(2)
25214         PV1  = PVIRT(2)
25215         IDP2 = 990
25216         PV2  = 0.D0
25217       ELSE IF(I.EQ.2) THEN
25218         IDP1 = IFPAP(1)
25219         PV1  = PVIRT(1)
25220         IDP2 = 990
25221         PV2  = 0.D0
25222       ELSE
25223         IDP1 = IFPAP(1)
25224         PV1  = PVIRT(1)
25225         IDP2 = IFPAP(2)
25226         PV2  = PVIRT(2)
25227       ENDIF
25228
25229 C  initialize PT scales
25230       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25231         IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25232           FPS(I) = PARMDL(105)
25233           FPH(I) = PARMDL(106)
25234         ELSE
25235           FPS(I) = PARMDL(103)
25236           FPH(I) = PARMDL(104)
25237         ENDIF
25238       ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25239         FPS(I) = PARMDL(103)
25240         FPH(I) = PARMDL(104)
25241       ELSE
25242         FPS(I) = PARMDL(101)
25243         FPH(I) = PARMDL(102)
25244       ENDIF
25245
25246 C  initialize hard scattering
25247       IF(IP.GT.0) THEN
25248         CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25249       ELSE
25250         CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25251       ENDIF
25252
25253 C  energy/virtuality grid
25254       do Ie=1,IH_Ecm_up(IL)
25255         HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25256       enddo
25257       do Ia=1,IH_Q2a_up(IL)
25258         HQ2a_tab(Ia,IL) = 0.D0
25259       enddo
25260       do Ib=1,IH_Q2b_up(IL)
25261         HQ2b_tab(Ib,IL) = 0.D0
25262       enddo
25263
25264 C  initialization for several energies and particle virtualities
25265       do Ie=1,IH_Ecm_up(IL)
25266         do Ia=1,IH_Q2a_up(IL)
25267           do Ib=1,IH_Q2b_up(IL)
25268
25269             EE = HEcm_tab(IE,IL)
25270             Q2a = HQ2a_tab(Ia,IL)
25271             Q2b = HQ2b_tab(Ib,IL)
25272             CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25273             IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25274      &        'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25275      &        PTCUT(I),EE,IDPDG1,IDPDG2
25276             Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25277             CALL PHO_HARFAC(PTCUT(I),EE)
25278             CALL PHO_HARWGX(PTCUT(I),EE)
25279             CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25280             IF(IDEB(8).GE.10) THEN
25281               WRITE(LO,'(1X,A,/,1X,A)')
25282      &          'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25283      &          '------------------------------------------------'
25284               DO M=0,Max_pro_2
25285                 WRITE(LO,'(10X,A,1P2E14.4)')
25286      &            PROC(M),DREAL(DSIG(M)),DSPT(M)
25287               ENDDO
25288             ENDIF
25289
25290 C  store in interpolation tables
25291             Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25292             HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25293             do M=0,Max_pro_2
25294               Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25295               HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25296               HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25297               Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25298             enddo
25299
25300 C  summed quantities
25301             HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25302             Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25303             do M=1,8
25304               IF(MH_pro_on(M,I).GT.0) THEN
25305                 HSig_tab(9,IE,Ia,Ib,IL) =
25306      &            HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25307                 Hdpt_tab(9,IE,Ia,Ib,IL) =
25308      &            Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25309               ENDIF
25310             enddo
25311             HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25312             Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25313             do M=10,14
25314               IF(MH_pro_on(M,I).GT.0) THEN
25315                 HSig_tab(15,IE,Ia,Ib,IL) =
25316      &            HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25317                 Hdpt_tab(15,IE,Ia,Ib,IL) =
25318      &            Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25319               ENDIF
25320             enddo
25321             HSig_tab(0,IE,Ia,Ib,IL) =
25322      &        HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25323             Hdpt_tab(0,IE,Ia,Ib,IL) =
25324      &        Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25325
25326           enddo
25327         enddo
25328       enddo
25329
25330 C  debug output of weights
25331  1000 CONTINUE
25332       IF(IDEB(8).GE.5) THEN
25333         WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25334      &    'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25335      &    IDPDG1,IDPDG2,IP,PTCUT(I),
25336      &    '------------------------------------------'
25337         DO M=-1,Max_pro_2
25338           IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25339           WRITE(LO,'(2X,A,I3,2I7)')
25340      &      'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25341      &      M,IDPDG1,IDPDG2
25342           do k=1,IH_Ecm_up(IL)
25343             do ia=1,IH_Q2a_up(IL)
25344               do ib=1,IH_Q2b_up(IL)
25345                 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25346      &            HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25347      &            Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25348      &            HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25349               enddo
25350             enddo
25351           enddo
25352  512      CONTINUE
25353         ENDDO
25354       ENDIF
25355
25356       END
25357
25358 *$ CREATE PHO_HARXR3.FOR
25359 *COPY PHO_HARXR3
25360 CDECK  ID>, PHO_HARXR3
25361       SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25362 C**********************************************************************
25363 C
25364 C     differential cross section DSIG/(DETAC*DETAD*DPT)
25365 C
25366 C     input:  ECMH     CMS energy
25367 C             PT       parton PT
25368 C             ETAC     pseudorapidity of parton C
25369 C             ETAD     pseudorapidity of parton D
25370 C
25371 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25372 C
25373 C**********************************************************************
25374       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25375       SAVE
25376
25377       PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25378
25379       PARAMETER ( Max_pro_2 = 16 )
25380       COMPLEX*16 DSIGMC
25381       DIMENSION DSIGMC(0:Max_pro_2)
25382       DIMENSION DSIGM(0:Max_pro_2)
25383
25384 C  input/output channels
25385       INTEGER LI,LO
25386       COMMON /POINOU/ LI,LO
25387 C  some constants
25388       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25389       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25390      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25391 C  Reggeon phenomenology parameters
25392       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25393      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25394       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25395      &                ALREG,ALREGP,GR(2),B0REG(2),
25396      &                GPPP,GPPR,B0PPP,B0PPR,
25397      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25398 C  currently activated parton density parametrizations
25399       CHARACTER*8 PDFNAM
25400       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25401       DOUBLE PRECISION PDFLAM,PDFQ2M
25402       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25403      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25404 C  hard scattering parameters used for most recent hard interaction
25405       INTEGER NFbeta,NF
25406       DOUBLE PRECISION ALQCD2,BQCD
25407       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25408 C  scale parameters for parton model calculations
25409       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25410       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25411       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25412      &                NQQAL,NQQALI,NQQALF,NQQPD
25413
25414       DOUBLE PRECISION PHO_ALPHAS
25415       DIMENSION PDA(-6:6),PDB(-6:6)
25416
25417       DO 10 I=1,9
25418         DSIGMC(I) = CMPLX(0.D0,0.D0)
25419         DSIGM(I)  = 0.D0
25420 10    CONTINUE
25421
25422       EC     = EXP(ETAC)
25423       ED     = EXP(ETAD)
25424 C  kinematic conversions
25425       XA     = PT*(EC+ED)/ECMH
25426       XB     = XA/(EC*ED)
25427       IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25428         WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25429         RETURN
25430       ENDIF
25431       SP     = XA*XB*ECMH*ECMH
25432       UP     =-ECMH*PT*EC*XB
25433       UP     = UP/SP
25434       TP     =-(1.D0+UP)
25435       UU     = UP*UP
25436       TT     = TP*TP
25437 C  set hard scale  QQ  for alpha and partondistr.
25438       IF     ( NQQAL.EQ.1 ) THEN
25439         QQAL = AQQAL*PT*PT
25440       ELSEIF ( NQQAL.EQ.2 ) THEN
25441         QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25442       ELSEIF ( NQQAL.EQ.3 ) THEN
25443         QQAL = AQQAL*SP
25444       ELSEIF ( NQQAL.EQ.4 ) THEN
25445         QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25446       ENDIF
25447       IF     ( NQQPD.EQ.1 ) THEN
25448         QQPD = AQQPD*PT*PT
25449       ELSEIF ( NQQPD.EQ.2 ) THEN
25450         QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25451       ELSEIF ( NQQPD.EQ.3 ) THEN
25452         QQPD = AQQPD*SP
25453       ELSEIF ( NQQPD.EQ.4 ) THEN
25454         QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25455       ENDIF
25456
25457       ALPHA  = PHO_ALPHAS(QQAL,3)
25458       FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25459 C  parton distributions (times x)
25460       CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25461       CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25462       S1    = PDA(0)*PDB(0)
25463       S2    = 0.D0
25464       S3    = 0.D0
25465       S4    = 0.D0
25466       S5    = 0.D0
25467       DO 20 I=1,NF
25468         S2  = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25469         S3  = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25470         S4  = S4+PDA(I)+PDA(-I)
25471         S5  = S5+PDB(I)+PDB(-I)
25472 20    CONTINUE
25473 C  partial cross sections (including color and symmetry factors)
25474 C  resolved photon matrix elements (light quarks)
25475       DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25476       DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25477       DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25478       DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25479       DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25480       DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25481       DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25482       DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25483      &           (8.D0/27.D0)/(UP*TP))
25484 C
25485       DSIGM(1) = FACTOR*DSIGM(1)*S1
25486       DSIGM(2) = FACTOR*DSIGM(2)*S2
25487       DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25488       DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25489       DSIGM(5) = FACTOR*DSIGM(5)*S2
25490       DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25491       DSIGM(7) = FACTOR*DSIGM(7)*S3
25492       DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25493 C  complex part
25494       X=ABS(TP-UP)
25495       FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25496 C
25497       DO 50 I=1,8
25498         IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25499         DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25500         DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25501  50   CONTINUE
25502       END
25503
25504 *$ CREATE PHO_HARXR2.FOR
25505 *COPY PHO_HARXR2
25506 CDECK  ID>, PHO_HARXR2
25507       SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25508 C**********************************************************************
25509 C
25510 C     differential cross section DSIG/(DETAC*DPT)
25511 C
25512 C     input:  ECMH     CMS energy
25513 C             PT       parton PT
25514 C             ETAC     pseudorapidity of parton C
25515 C
25516 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25517 C
25518 C**********************************************************************
25519       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25520       SAVE
25521
25522       PARAMETER ( TINY= 1.D-20 )
25523
25524       PARAMETER ( Max_pro_2 = 16 )
25525       COMPLEX*16 DSIGMC
25526       DIMENSION DSIGMC(0:Max_pro_2)
25527
25528 C  input/output channels
25529       INTEGER LI,LO
25530       COMMON /POINOU/ LI,LO
25531 C  integration precision for hard cross sections (obsolete)
25532       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25533       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25534
25535       COMPLEX*16 DSIG1
25536       DIMENSION DSIG1(0:Max_pro_2)
25537       DIMENSION ABSZ(32),WEIG(32)
25538
25539       DO 10 M=1,9
25540         DSIGMC(M) = CMPLX(0.D0,0.D0)
25541         DSIG1(M)  = 0.D0
25542 10    CONTINUE
25543 C
25544       EC  = EXP(ETAC)
25545       ARG = ECMH/PT
25546       IF  ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25547       EDU = LOG(ARG-EC)
25548       EDL =-LOG(ARG-1.D0/EC)
25549       NPOINT = NGAUET
25550       CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25551       DO 30 I=1,NPOINT
25552         CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25553         DO 20 M=1,9
25554           PCTRL= DREAL(DSIG1(M))/TINY
25555           IF( PCTRL.GE.1.D0 ) THEN
25556             DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25557           ENDIF
25558 20      CONTINUE
25559 30    CONTINUE
25560       END
25561
25562 *$ CREATE PHO_HARXD2.FOR
25563 *COPY PHO_HARXD2
25564 CDECK  ID>, PHO_HARXD2
25565       SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25566 C**********************************************************************
25567 C
25568 C     differential cross section DSIG/(DETAC*DPT) for direct processes
25569 C
25570 C     input:  ECMH     CMS energy of scattering system
25571 C             PT       parton PT
25572 C             ETAC     pseudorapidity of parton C
25573 C
25574 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25575 C
25576 C**********************************************************************
25577       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25578       SAVE
25579
25580       PARAMETER ( Max_pro_2 = 16 )
25581       COMPLEX*16 DSIGMC
25582       DIMENSION DSIGMC(0:Max_pro_2)
25583       PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25584
25585 C  input/output channels
25586       INTEGER LI,LO
25587       COMMON /POINOU/ LI,LO
25588 C  model switches and parameters
25589       CHARACTER*8 MDLNA
25590       INTEGER ISWMDL,IPAMDL
25591       DOUBLE PRECISION PARMDL
25592       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25593 C  data of c.m. system of Pomeron / Reggeon exchange
25594       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25595       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25596      &                 SIDP,CODP,SIFP,COFP
25597       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25598      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25599      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25600 C  Reggeon phenomenology parameters
25601       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25602      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25603       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25604      &                ALREG,ALREGP,GR(2),B0REG(2),
25605      &                GPPP,GPPR,B0PPP,B0PPR,
25606      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25607 C  currently activated parton density parametrizations
25608       CHARACTER*8 PDFNAM
25609       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25610       DOUBLE PRECISION PDFLAM,PDFQ2M
25611       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25612      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25613 C  hard scattering parameters used for most recent hard interaction
25614       INTEGER NFbeta,NF
25615       DOUBLE PRECISION ALQCD2,BQCD
25616       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25617 C  some hadron information, will be deleted in future versions
25618       INTEGER NFS
25619       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25620       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25621 C  scale parameters for parton model calculations
25622       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25623       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25624       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25625      &                NQQAL,NQQALI,NQQALF,NQQPD
25626 C  some constants
25627       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25628       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25629      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25630
25631       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25632       DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25633
25634 *     ONE32=1.D0/9.D0
25635 *     TWO32=4.D0/9.D0
25636       DO 10 I=10,13
25637         DSIGMC(I) = CMPLX(0.D0,0.D0)
25638         DSIGM(I) = 0.D0
25639  10   CONTINUE
25640       DSIGMC(15) = CMPLX(0.D0,0.D0)
25641       DSIGM(15) = 0.D0
25642
25643 C  direct particle 1
25644       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25645         EC     = EXP(ETAC)
25646         ED     = ECMH/PT-EC
25647 C  kinematic conversions
25648         XA     = 1.D0
25649         XB     = 1.D0/(EC*ED)
25650         IF ( XB.GE.1.D0 ) THEN
25651           WRITE(LO,'(/1X,A,2E12.4)')
25652      &      'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25653           RETURN
25654         ENDIF
25655         SP     = XA*XB*ECMH*ECMH
25656         UP     =-ECMH*PT*EC*XB
25657         UP     = UP/SP
25658         TP     =-(1.D0+UP)
25659         UU     = UP*UP
25660         TT     = TP*TP
25661 C  set hard scale  QQ  for alpha and partondistr.
25662         IF     ( NQQAL.EQ.1 ) THEN
25663           QQAL = AQQAL*PT*PT
25664         ELSEIF ( NQQAL.EQ.2 ) THEN
25665           QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25666         ELSEIF ( NQQAL.EQ.3 ) THEN
25667           QQAL = AQQAL*SP
25668         ELSEIF ( NQQAL.EQ.4 ) THEN
25669           QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25670         ENDIF
25671         IF     ( NQQPD.EQ.1 ) THEN
25672           QQPD = AQQPD*PT*PT
25673         ELSEIF ( NQQPD.EQ.2 ) THEN
25674           QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25675         ELSEIF ( NQQPD.EQ.3 ) THEN
25676           QQPD = AQQPD*SP
25677         ELSEIF ( NQQPD.EQ.4 ) THEN
25678           QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25679         ENDIF
25680
25681         ALPHA2 = PHO_ALPHAS(QQAL,2)
25682         IF(IDPDG1.EQ.22) THEN
25683           ALPHA1 = pho_alphae(QQAL)
25684         ELSE IF(IDPDG1.EQ.990) THEN
25685           ALPHA1 = PARMDL(74)
25686         ENDIF
25687         FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25688 C  parton distribution (times x)
25689         CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25690         S1    = PDB(0)
25691 C  charge counting
25692         S2    = 0.D0
25693         S3    = 0.D0
25694         IF(IDPDG1.EQ.22) THEN
25695           DO 20 I=1,NF
25696 *           IF(MOD(I,2).EQ.0) THEN
25697 *             S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25698 *             S3 = S3 + TWO32
25699 *           ELSE
25700 *             S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25701 *             S3 = S3 + ONE32
25702 *           ENDIF
25703             S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25704             S3 = S3 + Q_ch2(I)
25705  20       CONTINUE
25706         ELSE IF(IDPDG1.EQ.990) THEN
25707           DO 25 I=1,NF
25708             S2 = S2 + PDB(I)+PDB(-I)
25709  25       CONTINUE
25710           S3 = NF
25711         ENDIF
25712 C  partial cross sections (including color and symmetry factors)
25713 C  direct photon matrix elements
25714         DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25715         DSIGM(11) = (UU+TT)/(UP*TP)
25716 C
25717         DSIGM(10) = FACTOR*DSIGM(10)*S2
25718         DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25719 C  complex part
25720         X=ABS(TP-UP)
25721         FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25722 C
25723         DO 50 I=10,11
25724           IF(DSIGM(I).LT.0.D0) THEN
25725             WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25726      &        'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25727             DSIGM(I) = 0.D0
25728           ENDIF
25729           DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25730           DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25731  50     CONTINUE
25732       ENDIF
25733 C
25734 C  direct particle 2
25735       IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25736         EC     = EXP(ETAC)
25737         ED     = 1.D0/(ECMH/PT-1.D0/EC)
25738 C  kinematic conversions
25739         XA     = PT*(EC+ED)/ECMH
25740         XB     = 1.D0
25741         IF ( XA.GE.1.D0 ) THEN
25742           WRITE(LO,'(/1X,A,2E12.4)')
25743      &      'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25744           RETURN
25745         ENDIF
25746         SP     = XA*XB*ECMH*ECMH
25747         UP     =-ECMH*PT*EC*XB
25748         UP     = UP/SP
25749         TP     =-(1.D0+UP)
25750         UU     = UP*UP
25751         TT     = TP*TP
25752 C  set hard scale  QQ  for alpha and partondistr.
25753         IF     ( NQQAL.EQ.1 ) THEN
25754           QQAL = AQQAL*PT*PT
25755         ELSEIF ( NQQAL.EQ.2 ) THEN
25756           QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25757         ELSEIF ( NQQAL.EQ.3 ) THEN
25758           QQAL = AQQAL*SP
25759         ELSEIF ( NQQAL.EQ.4 ) THEN
25760           QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25761         ENDIF
25762         IF     ( NQQPD.EQ.1 ) THEN
25763           QQPD = AQQPD*PT*PT
25764         ELSEIF ( NQQPD.EQ.2 ) THEN
25765           QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25766         ELSEIF ( NQQPD.EQ.3 ) THEN
25767           QQPD = AQQPD*SP
25768         ELSEIF ( NQQPD.EQ.4 ) THEN
25769           QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25770         ENDIF
25771
25772         ALPHA1 = PHO_ALPHAS(QQAL,1)
25773         IF(IDPDG2.EQ.22) THEN
25774           ALPHA2 = pho_alphae(QQAL)
25775         ELSE IF(IDPDG2.EQ.990) THEN
25776           ALPHA2 = PARMDL(74)
25777         ENDIF
25778         FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
25779 C  parton distribution (times x)
25780         CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25781         S1    = PDA(0)
25782 C  charge counting
25783         S2    = 0.D0
25784         S3    = 0.D0
25785         IF(IDPDG2.EQ.22) THEN
25786           DO 70 I=1,NF
25787 *           IF(MOD(I,2).EQ.0) THEN
25788 *             S2 = S2 + (PDA(I)+PDA(-I))*TWO32
25789 *             S3 = S3 + TWO32
25790 *           ELSE
25791 *             S2 = S2 + (PDA(I)+PDA(-I))*ONE32
25792 *             S3 = S3 + ONE32
25793 *           ENDIF
25794             S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
25795             S3 = S3 + Q_ch2(I)
25796  70       CONTINUE
25797         ELSE IF(IDPDG2.EQ.990) THEN
25798           DO 75 I=1,NF
25799             S2 = S2 + PDA(I)+PDA(-I)
25800  75       CONTINUE
25801           S3 = NF
25802         ENDIF
25803 C  partial cross sections (including color and symmetry factors)
25804 C  direct photon matrix elements
25805         DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
25806         DSIGM(13) = (UU+TT)/(UP*TP)
25807 C
25808         DSIGM(12) = FACTOR*DSIGM(12)*S2
25809         DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
25810 C  complex part
25811         X=ABS(TP-UP)
25812         FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25813 C
25814         DO 80 I=12,13
25815           IF(DSIGM(I).LT.0.D0) THEN
25816             WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25817      &        'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
25818             DSIGM(I) = 0.D0
25819           ENDIF
25820           DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25821           DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25822  80     CONTINUE
25823       ENDIF
25824       END
25825
25826 *$ CREATE PHO_HARXPT.FOR
25827 *COPY PHO_HARXPT
25828 CDECK  ID>, PHO_HARXPT
25829       SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
25830 C**********************************************************************
25831 C
25832 C     differential cross section DSIG/DPT
25833 C
25834 C     input:  ECMH     CMS energy of scattering system
25835 C             PT       parton PT
25836 C             IPRO     1  resolved processes
25837 C                      2  direct processes
25838 C                      3  resolved and direct processes
25839 C
25840 C     output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
25841 C
25842 C**********************************************************************
25843       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25844       SAVE
25845
25846       PARAMETER ( Max_pro_2 = 16 )
25847       COMPLEX*16 DSIGMC
25848       DIMENSION  DSIGMC(0:Max_pro_2)
25849       PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
25850
25851 C  input/output channels
25852       INTEGER LI,LO
25853       COMMON /POINOU/ LI,LO
25854 C  some constants
25855       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25856       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25857      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25858 C  model switches and parameters
25859       CHARACTER*8 MDLNA
25860       INTEGER ISWMDL,IPAMDL
25861       DOUBLE PRECISION PARMDL
25862       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25863 C  data of c.m. system of Pomeron / Reggeon exchange
25864       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25865       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25866      &                 SIDP,CODP,SIFP,COFP
25867       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25868      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25869      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25870 C  Reggeon phenomenology parameters
25871       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25872      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25873       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25874      &                ALREG,ALREGP,GR(2),B0REG(2),
25875      &                GPPP,GPPR,B0PPP,B0PPR,
25876      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25877 C  integration precision for hard cross sections (obsolete)
25878       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25879       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25880 C  hard scattering parameters used for most recent hard interaction
25881       INTEGER NFbeta,NF
25882       DOUBLE PRECISION ALQCD2,BQCD
25883       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25884 C  some hadron information, will be deleted in future versions
25885       INTEGER NFS
25886       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25887       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25888
25889       double precision pho_alphae
25890
25891       COMPLEX*16 DSIG1
25892       DIMENSION  DSIG1(0:Max_pro_2)
25893       DIMENSION ABSZ(32),WEIG(32)
25894
25895       DO 10 M=0,Max_pro_2
25896         DSIGMC(M) = CMPLX(0.D0,0.D0)
25897         DSIG1(M)  = CMPLX(0.D0,0.D0)
25898  10   CONTINUE
25899
25900 C  resolved and direct processes
25901       AMT = 2.D0*PT/ECMH
25902       IF ( AMT.GE.1.D0 ) RETURN
25903       ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
25904       ECL = -ECU
25905       NPOINT = NGAUET
25906       CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
25907       DO 30 I=1,NPOINT
25908         DSIG1(9)  = CMPLX(0.D0,0.D0)
25909         DSIG1(15) = CMPLX(0.D0,0.D0)
25910         IF(IPRO.EQ.1) THEN
25911           CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25912         ELSE IF(IPRO.EQ.2) THEN
25913           CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25914         ELSE
25915           CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25916           CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25917         ENDIF
25918         DO 20 M=1,Max_pro_2
25919           DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25920  20     CONTINUE
25921  30   CONTINUE
25922
25923 C  direct processes
25924       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
25925      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
25926         FAC = 0.D0
25927         SS = ECMH*ECMH
25928         ALPHAE = pho_alphae(SS)
25929         DO 300 I=1,NF
25930           IF(IDPDG1.EQ.22) THEN
25931 *           F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25932             F1 = Q_ch2(I)*ALPHAE
25933           ELSE
25934             F1 = PARMDL(74)
25935           ENDIF
25936           IF(IDPDG2.EQ.22) THEN
25937 *           F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25938             F2 = Q_ch2(I)*ALPHAE
25939           ELSE
25940             F2 = PARMDL(74)
25941           ENDIF
25942           FAC = FAC+F1*F2*3.D0
25943  300    CONTINUE
25944 C  direct cross sections
25945         ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
25946         T1 = -SS/2.D0*(1.D0+ZZ)
25947         T2 = -SS/2.D0*(1.D0-ZZ)
25948         XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
25949 C  hadronic part
25950         DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
25951
25952 C  leptonic part (e, mu, tau)
25953         DSIGMC(16) = 0.D0
25954         IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
25955           DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
25956 C  simulation of tau together with quarks
25957           IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
25958         ENDIF
25959       ENDIF
25960
25961       DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
25962       DSIGMC(0)  = DSIGMC(9)+DSIGMC(15)
25963
25964       END
25965
25966 *$ CREATE PHO_HARXTO.FOR
25967 *COPY PHO_HARXTO
25968 CDECK  ID>, PHO_HARXTO
25969       SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
25970 C**********************************************************************
25971 C
25972 C     total hard cross section (perturbative QCD, Parton Model)
25973 C
25974 C     input:  ECMH     CMS energy of scattering system
25975 C             PTCUTR   PT cutoff for resolved processes
25976 C             PTCUTD   PT cutoff for direct processes (photon, Pomeron)
25977 C
25978 C     output: DSIGMC(0:MARPR2) cross sections for given cutoff
25979 C             DSDPTC(0:MARPR2) differential cross sections at cutoff
25980 C
25981 C     note:  COMPLEX*16          DSIGMC
25982 C            DOUBLE PRECISION    DSDPTC
25983 C
25984 C**********************************************************************
25985       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25986       SAVE
25987
25988       PARAMETER ( Max_pro_2 = 16 )
25989       COMPLEX*16 DSIGMC
25990       DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
25991
25992 C  input/output channels
25993       INTEGER LI,LO
25994       COMMON /POINOU/ LI,LO
25995 C  model switches and parameters
25996       CHARACTER*8 MDLNA
25997       INTEGER ISWMDL,IPAMDL
25998       DOUBLE PRECISION PARMDL
25999       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26000 C  data of c.m. system of Pomeron / Reggeon exchange
26001       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26002       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26003      &                 SIDP,CODP,SIFP,COFP
26004       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26005      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
26006      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
26007 C  Reggeon phenomenology parameters
26008       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26009      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26010       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26011      &                ALREG,ALREGP,GR(2),B0REG(2),
26012      &                GPPP,GPPR,B0PPP,B0PPR,
26013      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26014 C  some constants
26015       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26016       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26017      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26018 C  integration precision for hard cross sections (obsolete)
26019       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26020       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26021 C  some hadron information, will be deleted in future versions
26022       INTEGER NFS
26023       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26024       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26025 C  hard scattering parameters used for most recent hard interaction
26026       INTEGER NFbeta,NF
26027       DOUBLE PRECISION ALQCD2,BQCD
26028       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26029
26030       double precision pho_alphae
26031
26032       COMPLEX*16 DSIG1
26033       DIMENSION DSIG1(0:Max_pro_2)
26034       DIMENSION ABSZ(32),WEIG(32)
26035
26036       DATA FAC / 3.0D0 /
26037
26038       DO 10 M=0,Max_pro_2
26039         DSIGMC(M)= CMPLX(0.D0,0.D0)
26040  10   CONTINUE
26041       EEC=ECMH/2.001D0
26042 C
26043       IF ( PTCUTR.GE.EEC ) GOTO 100
26044 C
26045 C  integration for resolved processes
26046       PTMIN  = PTCUTR
26047       PTMAX  = MIN(FAC*PTMIN,EEC)
26048       NPOINT = NGAUP1
26049       CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26050       DO 60 M=1,9
26051         DSDPTC(M) = DREAL(DSIG1(M))
26052  60   CONTINUE
26053       DSIGH   = DREAL(DSIG1(9))
26054       PTMXX  = 0.95D0*PTMAX
26055       CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26056       DSIGL  = DREAL(DSIG1(9))
26057       EX     = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26058       EX1    = 1.0D0-EX
26059       DO 50 K=1,2
26060         IF ( PTMIN.GE.PTMAX ) GOTO 40
26061         RL   = PTMIN**EX1
26062         RU   = PTMAX**EX1
26063         CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26064         DO 30 I=1,NPOINT
26065           R  = ABSZ(I)
26066           PT = R**(1.0D0/EX1)
26067           CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26068           F  = WEIG(I)*PT/(R*EX1)
26069           DO 20 M=1,9
26070             DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26071  20       CONTINUE
26072  30     CONTINUE
26073  40     PTMIN  = PTMAX
26074         PTMAX  = EEC
26075         NPOINT = NGAUP2
26076  50   CONTINUE
26077  100  CONTINUE
26078       DSIGMC(0) = DSIGMC(9)
26079       DSDPTC(0) = DSDPTC(9)
26080 C
26081 C  integration for direct processes
26082       IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26083 C
26084       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26085      &   .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26086         PTMIN  = PTCUTD
26087         PTMAX  = MIN(FAC*PTMIN,EEC)
26088         NPOINT = NGAUP1
26089         CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26090         IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26091         DO 160 M=10,16
26092           DSDPTC(M) = DREAL(DSIG1(M))
26093  160    CONTINUE
26094         DSIGH   = DREAL(DSIG1(15)-DSIG1(14))
26095         PTMXX  = 0.95D0*PTMAX
26096         CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26097         DSIGL  = DREAL(DSIG1(15)-DSIG1(14))
26098         EX     = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26099         EX1    = 1.0D0-EX
26100         DO 150 K=1,2
26101           IF ( PTMIN.GE.PTMAX ) GOTO 140
26102           RL   = PTMIN**EX1
26103           RU   = PTMAX**EX1
26104           CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26105           DO 130 I=1,NPOINT
26106             R  = ABSZ(I)
26107             PT = R**(1.0D0/EX1)
26108             CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26109             F  = WEIG(I)*PT/(R*EX1)
26110             DO 120 M=10,15
26111               DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26112  120        CONTINUE
26113  130      CONTINUE
26114  140      PTMIN  = PTMAX
26115           PTMAX  = EEC
26116           NPOINT = NGAUP2
26117  150    CONTINUE
26118       ENDIF
26119 C
26120  170  CONTINUE
26121 C
26122 C  double direct process
26123       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26124      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26125         FACC = 0.D0
26126         SS = ECMH*ECMH
26127         ALPHAE = pho_alphae(SS)
26128         DO 300 I=1,NF
26129           IF(IDPDG1.EQ.22) THEN
26130 *           F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26131             F1 = Q_ch2(I)*ALPHAE
26132           ELSE
26133             F1 = PARMDL(74)
26134           ENDIF
26135           IF(IDPDG2.EQ.22) THEN
26136 *           F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26137             F2 = Q_ch2(I)*ALPHAE
26138           ELSE
26139             F2 = PARMDL(74)
26140           ENDIF
26141           FACC = FACC + F1*F2*3.D0
26142  300    CONTINUE
26143
26144         ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26145         R  = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26146 C  hadronic cross section
26147         DSIGMC(14) = R*FACC*AKFAC
26148 C  leptonic cross section
26149         IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26150           DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26151 C  simulation of tau together with quarks
26152           IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26153           DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26154         ELSE
26155           DSIGMC(16) = CMPLX(0.D0,0.D0)
26156         ENDIF
26157 C  sum of direct part
26158         DSIGMC(15) = CMPLX(0.D0,0.D0)
26159         DO 400 I=10,14
26160           DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26161  400    CONTINUE
26162       ENDIF
26163 C total sum (hadronic)
26164       DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26165       DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26166
26167       END
26168
26169 *$ CREATE PHO_HARISR.FOR
26170 *COPY PHO_HARISR
26171 CDECK  ID>, PHO_HARISR
26172       SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26173      &  XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26174 C********************************************************************
26175 C
26176 C     initial state radiation according to DGLAP evolution equations
26177 C     (backward evolution, no spin effects)
26178 C
26179 C     input:    IHPOM     index of hard Pomeron
26180 C                         negative: delete all previous entries
26181 C               P1,P2     4 momenta of hard scattered final partons
26182 C                         (in CMS of hard scattering)
26183 C               IPF1,2    flavours of final partons
26184 C               IPA1,2    flavours of initial partons
26185 C               IV1,2     valence quark labels (0/1)
26186 C               Q2H       momentum transfer (squared, positive)
26187 C               XH1,XH2   x values of initial partons
26188 C               XHMAX1,2  max. x values allowed
26189 C
26190 C     output:   all emitted partons in /POPISR/, final state
26191 C               partons are the first two entries
26192 C               shower evolution traced in /PODGL1/
26193 C               IPB1,2    flavours of new initial partons
26194 C               XISR1,2   x values of new initial partons
26195 C               IVO1,2    valence quark labels (0/1)
26196 C
26197 C     attention: quark numbering according to PDG convention,
26198 C                but 0 for gluons
26199 C
26200 C********************************************************************
26201       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26202       SAVE
26203
26204       PARAMETER (RHOMAS =  0.766D0,
26205      &           DEPS   =  1.D-10,
26206      &           TINY   =  1.D-10)
26207
26208       DIMENSION P1(4),P2(4)
26209
26210 C  input/output channels
26211       INTEGER LI,LO
26212       COMMON /POINOU/ LI,LO
26213 C  event debugging information
26214       INTEGER NMAXD
26215       PARAMETER (NMAXD=100)
26216       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26217      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26218       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26219      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26220 C  internal rejection counters
26221       INTEGER NMXJ
26222       PARAMETER (NMXJ=60)
26223       CHARACTER*10 REJTIT
26224       INTEGER IFAIL
26225       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26226 C  model switches and parameters
26227       CHARACTER*8 MDLNA
26228       INTEGER ISWMDL,IPAMDL
26229       DOUBLE PRECISION PARMDL
26230       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26231 C  data of c.m. system of Pomeron / Reggeon exchange
26232       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26233       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26234      &                 SIDP,CODP,SIFP,COFP
26235       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26236      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
26237      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
26238 C  some hadron information, will be deleted in future versions
26239       INTEGER NFS
26240       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26241       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26242 C  currently activated parton density parametrizations
26243       CHARACTER*8 PDFNAM
26244       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26245       DOUBLE PRECISION PDFLAM,PDFQ2M
26246       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26247      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26248 C  scale parameters for parton model calculations
26249       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26250       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26251       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26252      &                NQQAL,NQQALI,NQQALF,NQQPD
26253 C  parameters for DGLAP backward evolution in ISR
26254       INTEGER NFSISR
26255       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26256       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26257 C  initial state parton radiation (internal part)
26258       INTEGER MXISR3,MXISR4
26259       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26260       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26261       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26262       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26263      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26264      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
26265      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26266 C  some constants
26267       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26268       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26269      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26270 C  particles created by initial state evolution
26271       INTEGER MXISR1,MXISR2
26272       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26273       INTEGER IFLISR,IPOISR,IMXISR
26274       DOUBLE PRECISION PHISR
26275       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26276      &                IPOISR(2,2,MXISR2),IMXISR(2)
26277
26278       DOUBLE PRECISION PYP,EER,THER,QMAXR
26279       INTEGER PYK
26280
26281       DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26282      &          WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26283      &          IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26284
26285       IREJ = 0
26286       NTRY = 1000
26287       NITER = 0
26288 C  debug output
26289       IF(IDEB(79).GE.10) THEN
26290         WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26291      &    'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26292      &    KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26293       ENDIF
26294       IF(IHPOM.EQ.0) RETURN
26295 C
26296  10   CONTINUE
26297       NACC = 0
26298       IDMO(1) = IDPDG1
26299       IDMO(2) = IDPDG2
26300 C
26301 C  copy final state partons to local fields
26302       IHIDX = ABS(IHPOM)
26303       IF(IHIDX.GT.MXISR2) THEN
26304         WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26305      &    '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26306      &    IHIDX,MXISR2
26307         IREJ = 1
26308       ENDIF
26309       DO 50 K=1,2
26310         IF(IHPOM.LT.0) IMXISR(K) = 0
26311         IPOISR(K,1,IHIDX) = IMXISR(K)+1
26312         IPAL(K) = IPOISR(K,1,IHIDX)
26313  50   CONTINUE
26314       DO 55 I=1,4
26315         PHISR(1,I,IPAL(1)) = P1(I)
26316         PHISR(2,I,IPAL(2)) = P2(I)
26317  55   CONTINUE
26318       IFLISR(1,IPAL(1)) = IPF1
26319       IFLISR(2,IPAL(2)) = IPF2
26320 C
26321 C  check limitations, initialize /PODGL1/
26322       IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26323         NEXT(1) = 1
26324         Q2SH(1,1) = Q2H
26325       ELSE
26326         NEXT(1) = 0
26327         Q2SH(1,1) = 0.D0
26328       ENDIF
26329       IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26330         NEXT(2) = 1
26331         Q2SH(2,1) = Q2H
26332       ELSE
26333         NEXT(2) = 0
26334         Q2SH(2,1) = 0.D0
26335       ENDIF
26336 C
26337       ISH(1) = 1
26338       ISH(2) = 1
26339       XPSH(1,1) = XH1
26340       XPSH(2,1) = XH2
26341 C
26342       IFL1(1,1) = IPA1
26343       IVAL(1)   = IV1
26344       IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26345       IFL1(2,1) = IPA2
26346       IVAL(2)   = IV2
26347       IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26348 C
26349       IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26350      &  'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26351       IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26352 C
26353 C  initialize parton shower loop
26354       B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26355       AL2ISR(1) = PDFLAM(1)
26356       AL2ISR(2) = PDFLAM(2)
26357       XHMA(1) = XHMAX1
26358       XHMA(2) = XHMAX2
26359       XHMI(1) = PMISR(1)/PCMP
26360       XHMI(2) = PMISR(2)/PCMP
26361       ZPSH(1,1) = 1.D0
26362       ZPSH(2,1) = 1.D0
26363       SHAT1 = XH1*XH2*ECMP**2
26364       IF(IPAMDL(109).EQ.1) THEN
26365         PT2SH(1,1) = Q2H
26366       ELSE
26367         PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26368       ENDIF
26369       PT2SH(2,1) = PT2SH(1,1)
26370       IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26371       IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26372       THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26373       THSH(2,1) = THSH(1,1)
26374       IFANO(1) = 0
26375       IFANO(2) = 0
26376       ZZ = 1.D0
26377       IF(IREJ.NE.0) GOTO 800
26378 C
26379 C  main generation loop
26380 C -------------------------------------------------
26381  100  CONTINUE
26382 C  choose parton side to become solved
26383         IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26384           IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26385             IP = 1
26386           ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26387             IP = 2
26388           ELSE
26389             IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26390           ENDIF
26391         ELSE IF(NEXT(1).EQ.1) THEN
26392           IP = 1
26393         ELSE IF(NEXT(2).EQ.1) THEN
26394           IP = 2
26395         ELSE
26396           GOTO 800
26397         ENDIF
26398         INDX = ISH(IP)
26399 C  INDX now parton position of parton to become solved
26400 C  IP   now side to be treated
26401         XP = XPSH(IP,INDX)
26402         Q2P = Q2SH(IP,INDX)
26403         PT2 = PT2SH(IP,INDX)
26404         IFLB = IFL1(IP,INDX)
26405 C  check available x
26406         XMIP = XHMI(IP)
26407 C  cutoff by x limitation: no further development
26408         IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26409           NEXT(IP) = 0
26410           Q2SH(IP,INDX) = 0.D0
26411           IF(IDEB(79).GE.17) THEN
26412             WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26413      &        'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26414      &        XP,XMIP,XHMA(IP),IP,INDX
26415           ENDIF
26416           GOTO 100
26417         ENDIF
26418 C  initial value of evolution variable t
26419         TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26420         DO 110 I=-NFSISR,NFSISR
26421           WGGAP(I) = 0.D0
26422           WGPDF(I) = 0.D0
26423  110    CONTINUE
26424 C  DGLAP weights
26425         ZMIN = XP/XHMA(IP)
26426         ZMAX = XP/(XP+XMIP)
26427         CF = 4./3.
26428 C  q --> q g, g --> g g
26429         IF(IFLB.EQ.0) THEN
26430           WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26431      &      +2.D0*LOG(ZMAX/ZMIN))
26432           DO 120 I=1,NFSISR
26433             WGGAP(I)  = WGGAP(0)
26434             WGGAP(-I) = WGGAP(0)
26435  120      CONTINUE
26436           WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26437      &      -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26438 C  q --> g q, g --> q qb
26439         ELSE IF(ABS(IFLB).LE.6) THEN
26440           WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26441      &      -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26442           IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26443      &      -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26444         ELSE
26445           WRITE(LO,'(/1X,A,I7)')
26446      &      'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26447           CALL PHO_ABORT
26448         ENDIF
26449 C  anomalous/resolved evolution
26450         IPDFC = 0
26451         IF(IPAMDL(110).GE.1) THEN
26452           IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26453      &       .AND.(IFLB.NE.21)) THEN
26454             WGDIR = 0.D0
26455             IF(NQQALI.EQ.1) THEN
26456               SCALE2 = PT2*AQQPD
26457             ELSE
26458               SCALE2 = Q2P*AQQPD
26459             ENDIF
26460             CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26461             IPDFC = 1
26462             CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26463             XI = DT_RNDM(XP)*PD1(IFLB)
26464             IF(WGDIR.GT.XI) THEN
26465 C  debug output
26466               IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26467      &          'PHO_HARISR: ',
26468      &          'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26469      &          WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26470               Q2SH(IP,INDX) = 0.D0
26471               NEXT(IP) = 0
26472               IFANO(IP) = INDX
26473               GOTO 100
26474             ENDIF
26475           ENDIF
26476         ENDIF
26477 C
26478 C  rejection loop for z,t sampling
26479 C ------------------------------------
26480  200    CONTINUE
26481           NITER = NITER+1
26482           IF(NITER.GE.NTRY) THEN
26483             WRITE(LO,'(1X,A,2I6)')
26484      &        'PHO_HARISR: too many rejections',NITER,NTRY
26485             CALL PHO_PREVNT(-1)
26486 C  clean up event
26487             IREJ = 1
26488             GOTO 10
26489           ENDIF
26490 C  PDF weights
26491           IF(IPDFC.EQ.0) THEN
26492             IF(NQQALI.EQ.1) THEN
26493               SCALE2 = PT2*AQQPD
26494             ELSE
26495               SCALE2 = Q2P*AQQPD
26496             ENDIF
26497             CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26498           ENDIF
26499           IPDFC = 0
26500 C
26501           WGTOT = 0.D0
26502           DO 210 I=-NFSISR,NFSISR
26503             WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26504             WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26505  210      CONTINUE
26506 C
26507  215      CONTINUE
26508 C  sample new t value
26509           TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26510           Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26511 C  debug output
26512           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26513      &      'PHO_HARISR: pre-selected Q2:',Q2NEW
26514 C  compare to limits
26515           IF(Q2NEW.LT.Q2MISR(IP)) THEN
26516             Q2SH(IP,INDX) = 0.D0
26517             NEXT(IP) = 0
26518             IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26519      &        'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26520      &        Q2NEW,Q2MISR(IP),IP,INDX
26521             GOTO 100
26522           ENDIF
26523           Q2SH(IP,INDX) = Q2NEW
26524           TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26525 C  selection of flavours
26526           XI = WGTOT*DT_RNDM(TT)
26527           IFLA = -NFSISR-1
26528  220      CONTINUE
26529             IFLA = IFLA+1
26530             XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26531           IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26532 C  debug output
26533           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26534      &      'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26535 C  selection of z
26536           CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26537 C  debug output
26538           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26539      &      'PHO_HARISR: pre-selected ZZ',ZZ
26540 C  angular ordering
26541           THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26542           IF(THETA.GT.THSH(IP,INDX)) THEN
26543             IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26544      &        'PHO_HARISR: reject by angle (NEW/OLD)',
26545      &        THETA,THSH(IP,INDX)
26546             GOTO 215
26547           ENDIF
26548 C  rejection weight given by new PDFs
26549           XNEW = XP/ZZ
26550           PT2NEW = Q2NEW*(1.D0-ZZ)
26551           IF(NQQALI.EQ.1) THEN
26552             SCALE2 = PT2NEW*AQQPD
26553           ELSE
26554             SCALE2 = Q2NEW*AQQPD
26555           ENDIF
26556           IF(SCALE2.LT.Q2MISR(IP)) THEN
26557             Q2SH(IP,INDX) = 0.D0
26558             NEXT(IP) = 0
26559             IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26560      &        'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26561      &        Q2NEW,Q2MISR(IP),IP,INDX
26562             GOTO 100
26563           ENDIF
26564           CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26565           IF(PD2(IFLA).LT.1.D-10) GOTO 200
26566           CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26567           PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26568           WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26569           IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26570      &      /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26571           IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26572             WRITE(LO,'(1X,A,E12.3)')
26573      &        'PHO_HARISR: final weight:',WGF
26574             WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26575      &      'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26576           ENDIF
26577         IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26578
26579         IF(IDEB(79).GE.15) THEN
26580           WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26581      &      'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26582      &      IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26583         ENDIF
26584
26585         IF(INDX.GE.MXISR3) THEN
26586           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26587      &      '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26588           IREJ = 1
26589           RETURN
26590         ENDIF
26591 C  branching accepted, registration
26592         Q2SH(IP,INDX) = Q2NEW
26593         PT2SH(IP,INDX) = PT2NEW
26594         ZPSH(IP,INDX) = ZZ
26595         IFL2(IP,INDX) = IFLA-IFLB
26596         Q2SH(IP,INDX+1) = Q2NEW
26597         PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26598         XPSH(IP,INDX+1) = XNEW
26599         THSH(IP,INDX+1) = THETA
26600         IFL1(IP,INDX+1) = IFLA
26601         ISH(IP) = ISH(IP)+1
26602
26603         NACC = NACC+1
26604         IF(NACC.GT.MXISR4) THEN
26605           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26606      &      '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26607           IREJ = 1
26608           RETURN
26609         ENDIF
26610         SHAT(NACC) = SHAT1
26611         IBRA(1,NACC) = IP
26612         IBRA(2,NACC) = INDX
26613         SHAT1 = SHAT1/ZZ
26614
26615 C  generation of next branching
26616       IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26617
26618  800  CONTINUE
26619
26620 C  new initial flavours, x values
26621       IPB1 = IFL1(1,ISH(1))
26622       IPB2 = IFL1(2,ISH(2))
26623       XISR1 = XPSH(1,ISH(1))
26624       XISR2 = XPSH(2,ISH(2))
26625       IVO1  = IVAL(1)
26626       IVO2  = IVAL(2)
26627 C  valence flavours
26628       IF(IPB1.NE.0) THEN
26629         IF(ISH(1).GT.1) THEN
26630           CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26631           IF(IDPDG1.EQ.22) THEN
26632             CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26633             IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26634           ELSE
26635             CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26636             IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26637           ENDIF
26638         ENDIF
26639       ENDIF
26640       IF(IPB2.NE.0) THEN
26641         IF(ISH(2).GT.1) THEN
26642           CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26643           IF(IDPDG2.EQ.22) THEN
26644             CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26645             IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26646           ELSE
26647             IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26648           ENDIF
26649         ENDIF
26650       ENDIF
26651
26652 C  parton kinematics
26653       IF(NACC.GT.0) THEN
26654 C  final partons in CMS
26655         PM(3) = (XH1-XH2)*ECMP/2.D0
26656         PM(4) = (XH1+XH2)*ECMP/2.D0
26657         SH = XH1*XH2*ECMP**2
26658         SSH = SQRT(SH)
26659         GB(3) = PM(3)/SSH
26660         GB(4) = PM(4)/SSH
26661         CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26662      &    P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26663      &    PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26664         CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26665      &    P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26666      &    PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26667         IL(1) = 1
26668         IL(2) = 1
26669         DO 900 I=1,NACC
26670           IPA = IBRA(1,I)
26671           IPB = 3-IPA
26672           IL(IPA) = IBRA(2,I)
26673 C  new initial partons in CMS
26674           SH = SHAT(I)
26675           SSH = SQRT(SH)
26676           SHZ = SH/ZPSH(IPA,IL(IPA))
26677           SSHZ = SQRT(SHZ)
26678           Q2(1) = Q2SH(1,IL(1))
26679           Q2(2) = Q2SH(2,IL(2))
26680           PC(1,1) = 0.D0
26681           PC(1,2) = 0.D0
26682           PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26683      &             /(2.D0*SSH)
26684           PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26685           PC(2,1) = 0.D0
26686           PC(2,2) = 0.D0
26687           PC(2,3) = -PC(1,3)
26688           PC(2,4) = SSH-PC(1,4)
26689           XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26690           EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26691           S1 = SH+Q2(IPA)+Q2(IPB)
26692           S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26693           R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26694           R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26695           IF(Q2(IPB).LT.0.1D0) THEN
26696             XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26697      &             *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26698           ELSE
26699             XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26700      &             -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26701           ENDIF
26702           NGEN = 1
26703 C  max. virtuality for time-like showers
26704           QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26705           IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26706 C  generate time-like parton shower
26707             KF = IFL2(IPA,IL(IPA))
26708             IF(KF.EQ.0) KF = 21
26709             EER = MIN(EE3-PC(IPA,4),ECMP)
26710             THER = 0.
26711             CALL PY1ENT(1,KF,EER,THER,THER)
26712             QMAXR = SQRT(QMAX)
26713             CALL PYSHOW(1,0,QMAXR)
26714 C debug output
26715             IF(IDEB(79).GE.25) THEN
26716               WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26717      &          'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26718      &          EER,QMAX,XMS4M,Q2(IPA)
26719               CALL PYLIST(1)
26720             ENDIF
26721             NGEN = PYK(0,1)
26722             IF(NGEN.GT.1) THEN
26723               PJX = 0.D0
26724               PJY = 0.D0
26725               PJZ = 0.D0
26726               PJE = 0.D0
26727               KK = IPAL(IPA)
26728               DO 820 K=3,NGEN
26729                 IF(PYK(K,1).LE.4) THEN
26730                   KK = KK+1
26731                   IF(KK.GT.MXISR1) THEN
26732                     WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26733      &                'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26734                     IREJ = 1
26735                     RETURN
26736                   ENDIF
26737                   PHISR(IPA,1,KK) = PYP(K,1)
26738                   PJX = PJX+PHISR(IPA,1,KK)
26739                   PHISR(IPA,2,KK) = PYP(K,2)
26740                   PJY = PJY+PHISR(IPA,2,KK)
26741                   PHISR(IPA,3,KK) = PYP(K,3)
26742                   PJZ = PJZ+PHISR(IPA,3,KK)
26743                   PHISR(IPA,4,KK) = PYP(K,4)
26744                   PJE = PJE+PHISR(IPA,4,KK)
26745                   IFLISR(IPA,KK)  = PYK(K,2)
26746                   IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26747                   IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26748                   IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26749                 ENDIF
26750  820          CONTINUE
26751               NGEN = KK-IPAL(IPA)
26752               XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26753               PP4  = SQRT(PJE**2-XMS4)
26754               EE3  = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26755 C debug output
26756               IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26757      &         'PHO_HARISR: ',
26758      &         'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26759      &         PJE,PJX,PJY,PJZ,PP4,XMS4
26760             ENDIF
26761           ENDIF
26762           PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26763      &          /(2.D0*PC(IPA,3))
26764           PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26765           IF(PT3.LT.0.D0) THEN
26766             IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
26767      &        'PHO_HARISR: rejection due to PT3',PT3
26768             GOTO 10
26769           ENDIF
26770           PT3 = SQRT(PT3)
26771           CALL PHO_SFECFE(SFE,CFE)
26772           PX3 = CFE*PT3
26773           PY3 = SFE*PT3
26774 C
26775           IF(NGEN.GT.1) THEN
26776 C  time-like shower generated
26777             EE4 = EE3-PC(IPA,4)
26778             PZ4 = PZ3-PC(IPA,3)
26779             PP4 = SQRT(PT3**2+PZ4**2)
26780 C  Lorentz boost
26781             GAM = (EE4*PJE-PP4*PJZ)/XMS4
26782             BEG = (PJE*PP4-EE4*PJZ)/XMS4
26783 C  rotation angles
26784             CODD = PZ4/PP4
26785             SIDD = SQRT(PX3**2+PY3**2)/PP4
26786             COFD = 1.D0
26787             SIFD = 0.D0
26788             IF(PP4*SIDD.GT.1.D-5) THEN
26789               COFD = PX3/(SIDD*PP4)
26790               SIFD = PY3/(SIDD*PP4)
26791               ANORF = SQRT(COFD*COFD+SIFD*SIFD)
26792               COFD = COFD/ANORF
26793               SIFD = SIFD/ANORF
26794             ENDIF
26795 C  copy partons back
26796             KK = IPAL(IPA)
26797             DO 830 K=1,NGEN
26798               KK = KK+1
26799               PX = PHISR(IPA,1,KK)
26800               PY = PHISR(IPA,2,KK)
26801               PZ = PHISR(IPA,3,KK)
26802               COH= PHISR(IPA,4,KK)
26803               EE = GAM*COH+BEG*PZ
26804               PZ = GAM*PZ +BEG*COH
26805               PHISR(IPA,4,KK) = EE
26806               CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
26807      &          PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
26808  830        CONTINUE
26809             IPAL(IPA) = KK
26810           ELSE
26811 C  no time-like shower generated
26812             IPAL(IPA) = IPAL(IPA)+1
26813             PHISR(IPA,1,IPAL(IPA)) = PX3
26814             PHISR(IPA,2,IPAL(IPA)) = PY3
26815             PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
26816             PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
26817             IFLISR(IPA,IPAL(IPA))  = IFL2(IPA,IL(IPA))
26818           ENDIF
26819           PC(IPA,1) = PX3
26820           PC(IPA,2) = PY3
26821           PC(IPA,3) = PZ3
26822           PC(IPA,4) = EE3
26823 C  boost / rotate into new CMS
26824           DO 842 K=1,4
26825             GB(K) = (PC(1,K)+PC(2,K))/SSHZ
26826  842      CONTINUE
26827           CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
26828      &      PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
26829           COG= PM(3)/PTOT1
26830           SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
26831           COH=1.D0
26832           SIH=0.D0
26833           IF(PTOT1*SIG.GT.1.D-5) THEN
26834             COH=PM(1)/(SIG*PTOT1)
26835             SIH=PM(2)/(SIG*PTOT1)
26836             ANORF=SQRT(COH*COH+SIH*SIH)
26837             COH=COH/ANORF
26838             SIH=SIH/ANORF
26839           ENDIF
26840           DO 845 K=1,2
26841             DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
26842               CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
26843      &          PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
26844      &          PTOT1,PM(1),PM(2),PM(3),PM(4))
26845               CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
26846      &          PN(2),PN(3))
26847               CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
26848      &          PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
26849               PHISR(K,4,L) = PM(4)
26850  844        CONTINUE
26851  845      CONTINUE
26852  900    CONTINUE
26853 C  boost back to global CMS
26854         PM(3) = (XISR1-XISR2)/2.D0
26855         PM(4) = (XISR1+XISR2)/2.D0
26856         SSH = SQRT(XISR1*XISR2)
26857         GB(3) = PM(3)/SSH
26858         GB(4) = PM(4)/SSH
26859         DO 945 K=1,2
26860           DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
26861             CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
26862      &        PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
26863      &        PM(2),PM(3),PM(4))
26864             PHISR(K,1,L) = PM(1)
26865             PHISR(K,2,L) = PM(2)
26866             PHISR(K,3,L) = PM(3)
26867             PHISR(K,4,L) = PM(4)
26868  944      CONTINUE
26869  945    CONTINUE
26870       ENDIF
26871       IPOISR(1,2,IHIDX) = IPAL(1)
26872       IPOISR(2,2,IHIDX) = IPAL(2)
26873       IMXISR(1) = IPAL(1)
26874       IMXISR(2) = IPAL(2)
26875 C
26876 C  debug output
26877       IF(IDEB(79).GE.10) THEN
26878         WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
26879      &    ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
26880         IF(NACC.GT.0) THEN
26881           WRITE(LO,'(1X,A,2I5,/6X,A)')
26882      &    'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
26883      &    ' SIDE   NO.   IFLB IFLC     Q2SH    PT2SH     XH         ZZ'
26884           DO 600 II=1,NACC
26885             K = IBRA(1,II)
26886             I = IBRA(2,II)
26887             WRITE(LO,'(5X,4I5,4E11.3)')
26888      &        K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
26889      &        ZPSH(K,I)
26890  600      CONTINUE
26891         ENDIF
26892 C  check of final configuration
26893         PX3 = 0.D0
26894         PY3 = 0.D0
26895         PZ3 = 0.D0
26896         EE3 = 0.D0
26897         IFSUM(1) = 0
26898         IFSUM(2) = 0
26899         WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
26900         DO 745 K=1,2
26901           DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
26902             WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
26903      &        PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
26904             IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
26905             PX3 = PX3 + PHISR(K,1,L)
26906             PY3 = PY3 + PHISR(K,2,L)
26907             PZ3 = PZ3 + PHISR(K,3,L)
26908             EE3 = EE3 + PHISR(K,4,L)
26909  744      CONTINUE
26910  745    CONTINUE
26911         IFSUM(1) = IFSUM(1)-IPB1
26912         IFSUM(2) = IFSUM(2)-IPB2
26913         PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
26914         EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
26915         WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
26916      &    IFSUM,PX3,PY3,PZ3,EE3
26917       ENDIF
26918       END
26919
26920 *$ CREATE PHO_HARZSP.FOR
26921 *COPY PHO_HARZSP
26922 CDECK  ID>, PHO_HARZSP
26923       SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
26924 C*********************************************************************
26925 C
26926 C     sampling of z values from DGLAP kernels
26927 C
26928 C     input:  IFLA,IFLB      parton flavours
26929 C             NFSH           flavours involved in hard processes
26930 C             ZMIN           minimal ZZ allowed
26931 C             ZMAX           maximal ZZ allowed
26932 C
26933 C     output: ZZ             z value
26934 C
26935 C*********************************************************************
26936       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26937       SAVE
26938
26939       PARAMETER ( DEPS   =  1.D-10 )
26940
26941 C  input/output channels
26942       INTEGER LI,LO
26943       COMMON /POINOU/ LI,LO
26944 C  event debugging information
26945       INTEGER NMAXD
26946       PARAMETER (NMAXD=100)
26947       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26948      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26949       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26950      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26951 C  internal rejection counters
26952       INTEGER NMXJ
26953       PARAMETER (NMXJ=60)
26954       CHARACTER*10 REJTIT
26955       INTEGER IFAIL
26956       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26957
26958       IF(ZMAX.LE.ZMIN) THEN
26959         WRITE(LO,'(1X,A,2E12.3)')
26960      &    'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
26961         CALL PHO_PREVNT(-1)
26962         ZZ = 0.D0
26963         RETURN
26964       ENDIF
26965 C
26966       IF(IFLB.EQ.0) THEN
26967         IF(IFLA.EQ.0) THEN
26968 C  g --> g g
26969           C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
26970           C2 = (1.D0-ZMIN)/ZMIN
26971  100      CONTINUE
26972             ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
26973           IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
26974         ELSE IF(ABS(IFLA).LE.NFSH) THEN
26975 C  q --> q g
26976           C1 = ZMAX/ZMIN
26977  200      CONTINUE
26978             ZZ = ZMIN*C1**DT_RNDM(ZMIN)
26979           IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
26980         ELSE
26981           GOTO 900
26982         ENDIF
26983       ELSE IF(ABS(IFLB).LE.NFSH) THEN
26984         IF(IFLA.EQ.0) THEN
26985 C  g --> q qb
26986           C1 = ZMAX-ZMIN
26987  300      CONTINUE
26988             ZZ = ZMIN+C1*DT_RNDM(ZMIN)
26989           IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
26990         ELSE IF(ABS(IFLA).LE.NFSH) THEN
26991 C  q --> g q
26992           C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
26993           C2 = 1.D0-ZMIN
26994  400      CONTINUE
26995             ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
26996           IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
26997         ELSE
26998           GOTO 900
26999         ENDIF
27000       ELSE
27001         GOTO 900
27002       ENDIF
27003 C  debug output
27004       IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
27005      &  'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
27006      &  IFLA,IFLB,ZZ,ZMIN,ZMAX
27007       RETURN
27008
27009  900  CONTINUE
27010       WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
27011      &  IFLA,IFLB
27012       CALL PHO_ABORT
27013
27014       END
27015
27016 *$ CREATE PHO_ALPHAE.FOR
27017 *COPY PHO_ALPHAE
27018 CDECK  ID>, PHO_ALPHAE
27019       DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
27020 C**********************************************************************
27021 C
27022 C     calculation of ALPHA_em
27023 C
27024 C     input:    Q2      scale in GeV**2
27025 C
27026 C**********************************************************************
27027       IMPLICIT NONE
27028       SAVE
27029
27030       DOUBLE PRECISION Q2
27031
27032 C  input/output channels
27033       INTEGER LI,LO
27034       COMMON /POINOU/ LI,LO
27035 C  model switches and parameters
27036       CHARACTER*8 MDLNA
27037       INTEGER ISWMDL,IPAMDL
27038       DOUBLE PRECISION PARMDL
27039       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27040
27041       DOUBLE PRECISION PYALEM
27042
27043       pho_alphae = 1.D0/137.D0
27044
27045       if(ipamdl(120).eq.1) then
27046         pho_alphae = PYALEM(Q2)
27047       endif
27048
27049       END
27050
27051 *$ CREATE PHO_ALPHAS.FOR
27052 *COPY PHO_ALPHAS
27053 CDECK  ID>, PHO_ALPHAS
27054       DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27055 C**********************************************************************
27056 C
27057 C     calculation of ALPHA_S
27058 C
27059 C     input:    IMODE = 1         lambda_QCD**2 for PDF 1 evolution
27060 C                       2         lambda_QCD**2 for PDF 2 evolution
27061 C                       3         lambda_QCD**2 for hard scattering
27062 C               Q2      scale in GeV**2
27063 C
27064 C     initialization needed:
27065 C               IMODE = 0         lambda values taken from PDF table
27066 C                       -1        given Q2 is 4-flavour lambda 1
27067 C                       -2        given Q2 is 4-flavour lambda 2
27068 C                       -3        given Q2 is 4-flavour lambda 3
27069 C
27070 C
27071 C**********************************************************************
27072       IMPLICIT NONE
27073       SAVE
27074
27075       DOUBLE PRECISION Q2
27076       INTEGER IMODE
27077
27078 C  input/output channels
27079       INTEGER LI,LO
27080       COMMON /POINOU/ LI,LO
27081 C  model switches and parameters
27082       CHARACTER*8 MDLNA
27083       INTEGER ISWMDL,IPAMDL
27084       DOUBLE PRECISION PARMDL
27085       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27086 C  hard scattering parameters used for most recent hard interaction
27087       INTEGER NFbeta,NF
27088       DOUBLE PRECISION ALQCD2,BQCD
27089       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27090 C  currently activated parton density parametrizations
27091       CHARACTER*8 PDFNAM
27092       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27093       DOUBLE PRECISION PDFLAM,PDFQ2M
27094       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27095      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27096
27097       INTEGER I
27098
27099       PHO_ALPHAS = 0.D0
27100
27101       IF(IMODE.GT.0) THEN
27102
27103         IF(Q2.LT.PARMDL(148)) THEN
27104           NFbeta = 1
27105         ELSE IF(Q2.LT.PARMDL(149)) THEN
27106           NFbeta = 2
27107         ELSE IF(Q2.LT.PARMDL(150)) THEN
27108           NFbeta = 3
27109         ELSE
27110           NFbeta = 4
27111         ENDIF
27112
27113         PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27114         NFbeta = NFbeta+2
27115
27116       ELSE IF(IMODE.EQ.0) THEN
27117
27118         DO I=1,3
27119           if(I.EQ.3) then
27120             ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27121           else
27122             ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27123           endif
27124           ALQCD2(I,1) = PARMDL(148)
27125      &                 *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27126           ALQCD2(I,3) = PARMDL(149)
27127      &                 *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27128           ALQCD2(I,4) = PARMDL(150)
27129      &                 *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27130
27131         ENDDO
27132
27133       ELSE IF(IMODE.LT.0) THEN
27134
27135         if(IMODE.eq.-4) then
27136           I = 3
27137           ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27138         else
27139           I = -IMODE
27140           ALQCD2(I,2) = Q2
27141         endif
27142         ALQCD2(I,1) = PARMDL(148)
27143      &               *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27144         ALQCD2(I,3) = PARMDL(149)
27145      &               *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27146         ALQCD2(I,4) = PARMDL(150)
27147      &               *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27148
27149       ENDIF
27150
27151       END
27152
27153 *$ CREATE PHO_DFWRAP.FOR
27154 *COPY PHO_DFWRAP
27155 CDECK  ID>, PHO_DFWRAP
27156       SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27157 C**********************************************************************
27158 C
27159 C     wrapper for diffraction dissociation in hadron-nucleus and
27160 C     nucleus-nucleus collisions with DPMJET
27161 C
27162 C     input:      MODE     1:   transformation into CMS
27163 C                          2:   transformation into Lab
27164 C                 JM1/2    indices of old mother particles
27165 C                 JM1/2N   indices of new mother particles
27166 C
27167 C**********************************************************************
27168       IMPLICIT NONE
27169       SAVE
27170
27171       INTEGER MODE,JM1,JM2
27172
27173 C  input/output channels
27174       INTEGER LI,LO
27175       COMMON /POINOU/ LI,LO
27176 C  event debugging information
27177       INTEGER NMAXD
27178       PARAMETER (NMAXD=100)
27179       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27180      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27181       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27182      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27183 C  standard particle data interface
27184       INTEGER NMXHEP
27185       PARAMETER (NMXHEP=4000)
27186       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27187       DOUBLE PRECISION PHEP,VHEP
27188       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27189      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27190      &                VHEP(4,NMXHEP)
27191 C  extension to standard particle data interface (PHOJET specific)
27192       INTEGER IMPART,IPHIST,ICOLOR
27193       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27194 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
27195       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27196       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27197       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27198      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27199
27200       DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27201       DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27202
27203       INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27204
27205 C  transformation into CMS
27206
27207       IF(MODE.EQ.1) THEN
27208
27209         JM1S = JM1
27210         JM2S = JM2
27211         NHEPS = NHEP
27212
27213         XM1 = PHEP(5,JM1)
27214         XM2 = PHEP(5,JM2)
27215
27216 C  boost into CMS
27217         P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27218         P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27219         P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27220         P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27221         SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27222         ECMD = SQRT(SS)
27223         DO 10 I=1,4
27224           GAMBED(I) = P1(I)/ECMD
27225  10     CONTINUE
27226         CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27227      &             PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27228      &             PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27229 C  rotation angles
27230         CODD = P1(3)/PTOT1
27231         SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27232         COFD = 1.D0
27233         SIFD = 0.D0
27234         IF(PTOT1*SIDD.GT.1.D-5) THEN
27235           COFD = P1(1)/(SIDD*PTOT1)
27236           SIFD = P1(2)/(SIDD*PTOT1)
27237           ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27238           COFD = COFD/ANORF
27239           SIFD = SIFD/ANORF
27240         ENDIF
27241
27242 C  initial particles in CMS
27243
27244         P1(1) = 0.D0
27245         P1(2) = 0.D0
27246         P1(3) = ECMD/2.D0*XPSUB
27247         P1(4) = P1(3)
27248
27249         P2(1) = 0.D0
27250         P2(2) = 0.D0
27251         P2(3) = -ECMD/2.D0*XTSUB
27252         P2(4) = -P2(3)
27253
27254         CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27255
27256         CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27257      &    P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27258      &    ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27259
27260         CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27261      &    P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27262      &    ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27263
27264         JM1 = JM1N
27265         JM2 = JM2N
27266
27267 C  transformation into lab.
27268
27269       ELSE IF(MODE.EQ.2) THEN
27270
27271         CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27272      &    GAMBED(1),GAMBED(2),GAMBED(3))
27273
27274         JM1 = JM1S
27275         JM2 = JM2S
27276
27277 C  clean up after rejection
27278
27279       ELSE IF(MODE.EQ.-2) THEN
27280
27281         NHEP = NHEPS
27282
27283         JM1 = JM1S
27284         JM2 = JM2S
27285
27286       ELSE
27287
27288         WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27289
27290       ENDIF
27291
27292       END
27293
27294 *$ CREATE PHO_DIFDIS.FOR
27295 *COPY PHO_DIFDIS
27296 CDECK  ID>, PHO_DIFDIS
27297       SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27298      &                      MSOFT,MHARD,IREJ)
27299 C***********************************************************************
27300 C
27301 C     sampling of diffractive events of different kinds,
27302 C                            (produced particles stored in /POEVT1/)
27303 C
27304 C     input:   IDIF1/2   diffractive process particle 1/2
27305 C                          0   elastic/quasi-elastic scattering
27306 C                          1   diffraction dissociation
27307 C              IMOTH1/2  index of mother particles in /POEVT1/
27308 C              SPROB     suppression factor (survival probability) for
27309 C                        resolved diffraction dissociation
27310 C              IMODE     mode of operation
27311 C                          0  sampling of diffractive cut
27312 C                          1  sampling of enhanced cut
27313 C                          2  sampling of diffractive cut without
27314 C                             scattering (needed for double-pomeron)
27315 C                         -1  initialization
27316 C                         -2  output of statistics
27317 C
27318 C     output:   MSOFT    number of generated soft strings
27319 C               MHARD    number of generated hard strings
27320 C               IDIF1/2  diffraction label for particle 1/2 in /PROCES/
27321 C                          0   quasi elastic scattering
27322 C                          1   low-mass diffractive dissociation
27323 C                          2   soft high-mass diffractive dissociation
27324 C                          3   hard resolved diffractive dissociation
27325 C                          4   hard direct diffractive dissociation
27326 C               IREJ     rejection label
27327 C                          0  successful generation of partons
27328 C                          1  failure
27329 C
27330 C***********************************************************************
27331       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27332       SAVE
27333
27334       PARAMETER ( EPS  = 1.D-7,
27335      &            DEPS = 1.D-10)
27336
27337 C  input/output channels
27338       INTEGER LI,LO
27339       COMMON /POINOU/ LI,LO
27340 C  event debugging information
27341       INTEGER NMAXD
27342       PARAMETER (NMAXD=100)
27343       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27344      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27345       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27346      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27347 C  general process information
27348       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27349       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27350 C  internal rejection counters
27351       INTEGER NMXJ
27352       PARAMETER (NMXJ=60)
27353       CHARACTER*10 REJTIT
27354       INTEGER IFAIL
27355       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27356 C  global event kinematics and particle IDs
27357       INTEGER IFPAP,IFPAB
27358       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27359       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27360 C  c.m. kinematics of diffraction
27361       INTEGER NPOSD
27362       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27363      &                 SIDD,CODD,SIFD,COFD,PDCMS
27364       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27365      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27366 C  obsolete cut-off information
27367       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27368       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27369 C  some constants
27370       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27371       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27372      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27373 C  model switches and parameters
27374       CHARACTER*8 MDLNA
27375       INTEGER ISWMDL,IPAMDL
27376       DOUBLE PRECISION PARMDL
27377       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27378 C  Reggeon phenomenology parameters
27379       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27380      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27381       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27382      &                ALREG,ALREGP,GR(2),B0REG(2),
27383      &                GPPP,GPPR,B0PPP,B0PPR,
27384      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27385 C  parameters of 2x2 channel model
27386       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27387       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27388 C  table of particle indices for recursive PHOJET calls
27389       INTEGER MAXIPX
27390       PARAMETER ( MAXIPX = 100 )
27391       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27392       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27393      &                IPOIX1,IPOIX2,IPOIX3
27394 C  standard particle data interface
27395       INTEGER NMXHEP
27396       PARAMETER (NMXHEP=4000)
27397       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27398       DOUBLE PRECISION PHEP,VHEP
27399       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27400      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27401      &                VHEP(4,NMXHEP)
27402 C  extension to standard particle data interface (PHOJET specific)
27403       INTEGER IMPART,IPHIST,ICOLOR
27404       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27405 C  event weights and generated cross section
27406       INTEGER IPOWGC,ISWCUT,IVWGHT
27407       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27408       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27409      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27410
27411       DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27412       DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27413       DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27414      &          IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27415      &          IDIR(2),IPROC(2)
27416
27417       IF(IMODE.EQ.-1) THEN
27418 C  initialization
27419         RETURN
27420       ELSE IF(IMODE.EQ.-2) THEN
27421 C  output of statistics
27422         RETURN
27423       ENDIF
27424
27425       IREJ = 0
27426 C  mass cuts
27427       PIMASS  = 0.140D0
27428 C  debug output
27429       IF(IDEB(45).GE.10) THEN
27430         WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27431      &    'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27432      &    IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27433       ENDIF
27434       IPAR(1) = IDIF1
27435       IPAR(2) = IDIF2
27436 C  save current status
27437       MSOFT = 0
27438       MHARD = 0
27439       KHPOMS = KHPOM
27440       KSPOMS = KSPOM
27441       KSREGS = KSREG
27442       KHDIRS = KHDIR
27443       IPOIS1 = IPOIX1
27444       IPOIS2 = IPOIX2
27445       IPOIS3 = IPOIX3
27446       JDA11 = JDAHEP(1,IMOTH1)
27447       JDA21 = JDAHEP(2,IMOTH1)
27448       JDA12 = JDAHEP(1,IMOTH2)
27449       JDA22 = JDAHEP(2,IMOTH2)
27450       ISTH1 = ISTHEP(IMOTH1)
27451       ISTH2 = ISTHEP(IMOTH2)
27452       NHEPS = NHEP
27453 C  get mother data
27454       NPOSD(1) = IMOTH1
27455       NPOSD(2) = IMOTH2
27456       DO 20 I=1,2
27457         IDPDG(I) = IDHEP(NPOSD(I))
27458         IDBAM(I) = IMPART(NPOSD(I))
27459         AMP(I) = PHO_PMASS(IDBAM(I),0)
27460         IF(IDPDG(I).EQ.22) THEN
27461           PMASSD(I) = 0.765D0
27462           PVIRTD(I) = PHEP(5,NPOSD(I))**2
27463         ELSE
27464           PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27465           PVIRTD(I) = 0.D0
27466         ENDIF
27467  20   CONTINUE
27468 C  get CM system
27469       P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27470       P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27471       P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27472       P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27473       SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27474       ECMD = SQRT(SS)
27475       IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27476      &  'PHO_DIFDIS: availabe energy',ECMD
27477 C  check total available energy
27478       IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27479         IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27480      &    'PHO_DIFDIS: ',
27481      &    'not enough energy for inelastic diffraction',
27482      &    'ECM, particle masses:',ECMD,AMP
27483         IFAIL(7) = IFAIL(7)+1
27484         IREJ = 1
27485         RETURN
27486       ENDIF
27487 C  boost into CMS
27488       DO 10 I=1,4
27489         GAMBED(I) = P1(I)/ECMD
27490  10   CONTINUE
27491       CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27492      &           PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27493      &           PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27494 C  rotation angles
27495       CODD = P1(3)/PTOT1
27496       SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27497       COFD = 1.D0
27498       SIFD = 0.D0
27499       IF(PTOT1*SIDD.GT.1.D-5) THEN
27500         COFD = P1(1)/(SIDD*PTOT1)
27501         SIFD = P1(2)/(SIDD*PTOT1)
27502         ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27503         COFD = COFD/ANORF
27504         SIFD = SIFD/ANORF
27505       ENDIF
27506 C  initial particles in CMS
27507       PDCMS(1,1) = 0.D0
27508       PDCMS(2,1) = 0.D0
27509       PDCMS(3,1) = PTOT1
27510       PDCMS(4,1) = P1(4)
27511       PDCMS(1,2) = 0.D0
27512       PDCMS(2,2) = 0.D0
27513       PDCMS(3,2) = -PTOT1
27514       PDCMS(4,2) = ECMD-P1(4)
27515 C  get new CM momentum
27516       AM12 = PMASSD(1)**2
27517       AM22 = PMASSD(2)**2
27518       PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27519
27520 C  coherence constraint (min/max diffractive mass allowed)
27521       IF(IMODE.EQ.2) THEN
27522         THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27523         THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27524         THRM2 = SQRT(1-PARMDL(72))*ECMD
27525         THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27526       ELSE
27527         THRM1 = PARMDL(46)
27528         THRM2 = PARMDL(45)*ECMD
27529 C  check kinematic limits
27530         IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27531         IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27532       ENDIF
27533
27534 C  check energy vs. coherence constraints
27535       IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27536       IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27537
27538 C  no phase space available
27539       IF(IPAR(1)+IPAR(2).EQ.0) THEN
27540         IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27541      &    'PHO_DIFDIS: ',
27542      &    'not enough phase space for ine. diffraction (Ecm)',ECMD,
27543      &    'side 1: min. mass, upper mass limit:',
27544      &    MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27545      &    'side 2: min. mass, upper mass limit:',
27546      &    MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27547         IFAIL(7) = IFAIL(7)+1
27548         IREJ = 1
27549         RETURN
27550       ENDIF
27551
27552       ITRY = 0
27553       ITRYM = 10
27554       IPARS1 = IPAR(1)
27555       IPARS2 = IPAR(2)
27556
27557 C  main rejection loop
27558 C -------------------------------
27559  50   CONTINUE
27560       ITRY = ITRY+1
27561       IF(ITRY.GT.1) THEN
27562         IFAIL(13) = IFAIL(13)+1
27563         IF(ITRY.GE.ITRYM) THEN
27564           IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27565      &      'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27566           IFAIL(7) = IFAIL(7)+1
27567           IREJ = 1
27568           RETURN
27569         ENDIF
27570       ENDIF
27571       KSPOM = KSPOMS
27572       KHPOM = KHPOMS
27573       KHDIR = KHDIRS
27574       KSREG = KSREGS
27575       IPAR(1) = IPARS1
27576       IPAR(2) = IPARS2
27577 C  reset mother-daugther relations
27578       NHEP = NHEPS
27579       JDAHEP(1,IMOTH1) = JDA11
27580       JDAHEP(2,IMOTH1) = JDA21
27581       JDAHEP(1,IMOTH2) = JDA12
27582       JDAHEP(2,IMOTH2) = JDA22
27583       ISTHEP(IMOTH1) = ISTH1
27584       ISTHEP(IMOTH2) = ISTH2
27585       IPOIX1 = IPOIS1
27586       IPOIX2 = IPOIS2
27587       IPOIX3 = IPOIS3
27588 C
27589       NSLP = 0
27590       NCOR = 0
27591  55   CONTINUE
27592
27593 C  calculation of kinematics
27594       DO 100 I=1,2
27595 C  sampling of masses
27596         IRPDG(I) = 0
27597         IRBAM(I) = 0
27598         IFL1P(I) = IDPDG(I)
27599         IFL2P(I) = IDBAM(I)
27600         IVEC(I)  = 0
27601         IDIR(I) = 0
27602         ISAM(I) = 0
27603         JSAM(I) = 0
27604         KSAM(I) = 0
27605         IF(IPAR(I).EQ.0) THEN
27606 C  vector meson dominance assumed
27607           XMASS(I) = AMP(I)
27608           CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27609 C  diffraction dissociation
27610         ELSE IF(IPAR(I).EQ.1) THEN
27611           XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27612           PREF2 = PMASSD(I)**2
27613           XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27614         ELSE
27615           WRITE(LO,'(/1X,A,2I3)')
27616      &      'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27617           CALL PHO_ABORT
27618         ENDIF
27619  100  CONTINUE
27620
27621 C  sampling of momentum transfer
27622       CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27623      &            THRM2,TT,SLWGHT,IREJ)
27624       IF(IREJ.NE.0) THEN
27625         NSLP=NSLP+1
27626         IF(NSLP.LT.100) GOTO 55
27627         WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27628      &   'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27629         IREJ = 5
27630         RETURN
27631       ENDIF
27632
27633 C  correct for t-M^2 correlation in diffraction
27634       IF(DT_RNDM(TT).GT.SLWGHT) THEN
27635         NCOR=NCOR+1
27636         IF(NCOR.LT.100) GOTO 55
27637         WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27638      &   'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27639         IREJ = 5
27640         RETURN
27641       ENDIF
27642
27643 C  debug output
27644       IF(IDEB(45).GE.5) THEN
27645         WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27646      &    'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27647       ENDIF
27648 C  not double pomeron scattering
27649       IF(IMODE.NE.2) THEN
27650 C  sample diffractive interaction processes
27651         DO 120 I=1,2
27652           IF(IPAR(I).NE.0) THEN
27653 C  find particle combination
27654             IF(IDPDG(I).EQ.IFPAP(1)) THEN
27655               IP = 2
27656             ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27657               IP = 3
27658             ELSE IF(IDPDG(I).EQ.990) THEN
27659               IP = 4
27660             ELSE
27661               IP = I+1
27662             ENDIF
27663 C  sample dissociation process
27664             CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27665      &        PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27666      &        KSAM(I),IDIR(I))
27667             IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27668 C  store process label
27669               IF(IDIR(I).GT.0) THEN
27670                 IPAR(I) = 4
27671               ELSE IF(KSAM(I).GT.0) THEN
27672                 IPAR(I) = 3
27673               ELSE IF(ISAM(I).GT.0) THEN
27674                 IPAR(I) = 2
27675               ELSE
27676                 IPAR(I) = 1
27677 C  mass fine correction
27678                 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27679      &            XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27680                 XMASS(I) = XMNEW
27681               ENDIF
27682             ELSE
27683 C  diffractive pomeron-hadron interaction
27684               IPAR(I) = 10+IPROC(I)
27685             ENDIF
27686 C  debug output
27687             IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27688      &        'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27689      &        IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27690           ENDIF
27691  120    CONTINUE
27692       ENDIF
27693 C  actualize debug information
27694       IF(IMODE.EQ.1) THEN
27695         IDIFR1 = IPAR(1)
27696         IDIFR2 = IPAR(2)
27697       ENDIF
27698 C  calculate new momenta in CMS
27699       CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27700       IF(IREJ.NE.0) GOTO 50
27701       DO 130 I=1,4
27702         PP(I,1) = P1(I)
27703         PP(I,2) = P2(I)
27704  130  CONTINUE
27705
27706 C  comment line for diffraction
27707       CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27708      &   XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27709 C  write diffractive strings/particles
27710       DO 200 I=1,2
27711         I1 = I
27712         I2 = 3-I1
27713         DO K=1,4
27714           PD1(K) = PP(K,I1)
27715           PD2(K) = PP(K,I2)
27716         ENDDO
27717         PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27718         PP(7,I1) = TT
27719         IGEN = IPHIST(2,NPOSD(I1))
27720         if(IGEN.eq.0) IGEN = -I1*10
27721         CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27722      &    IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27723         IF(IREJ.NE.0) THEN
27724           IFAIL(7+I) = IFAIL(7+I)+1
27725           IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27726      &      'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27727      &      I,IPAR(I),XMASS(I)
27728           GOTO 50
27729         ENDIF
27730         ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27731  200  CONTINUE
27732 C  double-pomeron scattering?
27733       IF(IMODE.EQ.2) GOTO 150
27734
27735 C  diffractive final states
27736       DO 300 I=1,2
27737  110    CONTINUE
27738         IF(IPAR(I).EQ.0) THEN
27739 C  vector meson production
27740           IF(IDPDG(I).EQ.22) THEN
27741             IF(ISWMDL(21).GE.0) THEN
27742               ISP = IPAMDL(3)
27743               IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27744               CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27745             ENDIF
27746 C  hadronic state of multi-pomeron coupling
27747           ELSE IF(IDPDG(I).EQ.990) THEN
27748             CALL PHO_SDECAY(IPOSP(1,I),0,2)
27749           ENDIF
27750         ELSE
27751           IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27752             IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
27753             IF(IDIR(I).GT.0) THEN
27754               IPAR(I) = 4
27755             ELSE IF(KSAM(I).GT.0) THEN
27756               IPAR(I) = 3
27757             ELSE IF(ISAM(I).GT.0) THEN
27758               IPAR(I) = 2
27759             ELSE
27760               IPAR(I) = 1
27761             ENDIF
27762           ELSE
27763             IPAR(I) = 10+IPROC(I)
27764           ENDIF
27765           IPHIST(I,ICPOS) = IPAR(I)
27766 C  update debug informantion
27767           KSPOM = ISAM(I)
27768           KSREG = JSAM(I)
27769           KHPOM = KSAM(I)
27770           KHDIR = IDIR(I)
27771           IDIFR1 = IPAR(1)
27772           IDIFR2 = IPAR(2)
27773           IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
27774
27775 C  resonance decay, pi+pi- background
27776             P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
27777             P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
27778             P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
27779             P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
27780             CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
27781      &        P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
27782 C  decay
27783             IF(IDPDG(I).EQ.22) THEN
27784               IPHIST(2,IPOS) = 3
27785               IF(ISWMDL(21).GE.0) THEN
27786                 ISP = IPAMDL(3)
27787                 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
27788                 CALL PHO_SDECAY(IPOS,ISP,2)
27789               ENDIF
27790             ELSE
27791               CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
27792             ENDIF
27793             IREJ = 0
27794           ELSE
27795
27796 C  particle-pomeron scattering
27797             IF(IPAR(I).LE.4) THEN
27798 C  non-diffractive particle-pomeron scattering
27799               IGEN = IPHIST(2,NPOSD(I))
27800               if(IGEN.eq.0) then
27801                 if(I.eq.1) then
27802                   IGEN = 5
27803                 else
27804                   IGEN = 6
27805                 endif
27806               endif
27807               CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
27808      &          ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
27809             ELSE
27810 C  diffractive particle-pomeron scattering
27811               IPOIX2 = IPOIX2+1
27812               IPORES(IPOIX2)   = IPROC(I)
27813               IPOPOS(1,IPOIX2) = IPOSP(1,I)
27814               IPOPOS(2,IPOIX2) = IPOSP(2,I)
27815             ENDIF
27816           ENDIF
27817         ENDIF
27818
27819 C  rejection?
27820         IF(IREJ.NE.0) THEN
27821           IFAIL(20+I) = IFAIL(20+I)+1
27822           IF(IPAR(I).GT.1) THEN
27823             IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
27824             IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
27825             IF(IDIR(I).GT.0) THEN
27826               IDIR(I) = 0
27827             ELSE IF(KSAM(I).GT.0) THEN
27828               KSAM(I) = KSAM(I)-1
27829             ELSE IF(ISAM(I).GT.0) THEN
27830               ISAM(I) = ISAM(I)-1
27831             ENDIF
27832             GOTO 110
27833           ELSE
27834             IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
27835      &        'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
27836      &        I,IPAR(I),XMASS(I)
27837             GOTO 50
27838           ENDIF
27839         ENDIF
27840  300  CONTINUE
27841
27842       IDIF1 = IPAR(1)
27843       IDIF2 = IPAR(2)
27844 C  update debug information
27845       KSPOM = KSPOMS+ISAM(1)+ISAM(2)
27846       KSREG = KSREGS+JSAM(1)+JSAM(2)
27847       KHPOM = KHPOMS+KSAM(1)+KSAM(2)
27848       KHDIR = KHDIRS+IDIR(1)+IDIR(2)
27849
27850  150  CONTINUE
27851
27852 C  debug output
27853       IF(IDEB(45).GE.10) THEN
27854         WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
27855      &    'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27856      &    IPAR,NPOSD,MSOFT,MHARD,IMODE
27857       ENDIF
27858       IF(IDEB(45).GE.15) THEN
27859         WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
27860      &                        '------------------------------'
27861         CALL PHO_PREVNT(0)
27862       ENDIF
27863
27864       END
27865
27866 *$ CREATE PHO_DIFPRO.FOR
27867 *COPY PHO_DIFPRO
27868 CDECK  ID>, PHO_DIFPRO
27869       SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
27870      &                  IPROC,ISAM,JSAM,KSAM,IDIR)
27871 C*********************************************************************
27872 C
27873 C     sampling of diffraction dissociation process
27874 C
27875 C     input:  IP       particle combination
27876 C             ICUT     user imposed limitations
27877 C             ID1/2    PDG particle code of scattering particles
27878 C             XMASS    diffractively produced mass (GeV)
27879 C             P2V1/2   virtuality of scattering particles (Gev**2)
27880 C             SPROB    suppression factor for resolved single and
27881 C                      double diffraction dissociation
27882 C
27883 C     output: IRPOC    process ID
27884 C             ISAM     number of cut pomerons (soft)
27885 C             JSAM     number of cut reggeons
27886 C             KSAM     number of cut pomerons (hard)
27887 C             IDIR     direct hard interaction
27888 C
27889 C*********************************************************************
27890       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27891       SAVE
27892
27893 C  input/output channels
27894       INTEGER LI,LO
27895       COMMON /POINOU/ LI,LO
27896 C  event debugging information
27897       INTEGER NMAXD
27898       PARAMETER (NMAXD=100)
27899       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27900      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27901       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27902      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27903 C  general process information
27904       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27905       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27906 C  model switches and parameters
27907       CHARACTER*8 MDLNA
27908       INTEGER ISWMDL,IPAMDL
27909       DOUBLE PRECISION PARMDL
27910       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27911 C  energy-interpolation table
27912       INTEGER IEETA2
27913       PARAMETER ( IEETA2 = 20 )
27914       INTEGER ISIMAX
27915       DOUBLE PRECISION SIGTAB,SIGECM
27916       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
27917
27918       ISAM = 0
27919       JSAM = 0
27920       KSAM = 0
27921       IDIR = 0
27922
27923       IF(XMASS.GT.3.D0) THEN
27924 C  rapidity gap survival probability
27925         SPRO = 1.D0
27926         IF(ISWMDL(28).GE.1) SPRO = SPROB
27927 C  sample interaction
27928         IPROC = 0
27929         CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
27930       ELSE
27931         IPROC = 1
27932       ENDIF
27933       IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
27934 C  non-diffractive hadron-pomeron interaction
27935       IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
27936 C  option for suppression of multiple interaction
27937         IF(ICUT.EQ.0) THEN
27938           IPROC = 1
27939           IF(ISAM+KSAM+IDIR.GT.0) THEN
27940             ISAM = 1
27941             JSAM = 0
27942           ELSE
27943             JSAM = 1
27944           ENDIF
27945           KSAM = 0
27946           IDIR = 0
27947         ELSE IF(ICUT.EQ.1) THEN
27948           IF(IDIR.GT.0) THEN
27949           ELSE IF(KSAM.GT.0) THEN
27950             KSAM = 1
27951             ISAM = 0
27952             JSAM = 0
27953           ELSE IF(ISAM.GT.0) THEN
27954             ISAM = 1
27955             JSAM = 0
27956           ELSE
27957             JSAM = 1
27958           ENDIF
27959         ELSE IF(ICUT.EQ.2) THEN
27960           KSAM = MIN(KSAM,1)
27961         ELSE IF(ICUT.EQ.3) THEN
27962           ISAM = MIN(ISAM,1)
27963         ENDIF
27964       ENDIF
27965       END
27966
27967 *$ CREATE PHO_DIFPAR.FOR
27968 *COPY PHO_DIFPAR
27969 CDECK  ID>, PHO_DIFPAR
27970       SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
27971      &                     IPOSH1,IPOSH2,IMODE,IREJ)
27972 C***********************************************************************
27973 C
27974 C     perform string construction for diffraction dissociation
27975 C
27976 C     input:     IMOTH1,2     index of mother particles in POEVT1
27977 C                IGENM        production process of mother particles
27978 C                IFL1,IFL2    particle numbers
27979 C                             (IDPDG,IDBAM for quasi-elas. hadron)
27980 C                IPAR         0  quasi-elasic scattering
27981 C                             1  single string configuration
27982 C                             2  two string configuration
27983 C                P1           massive 4 momentum of first
27984 C                P1(6)        virtuality/squ.mass of particle (GeV**2)
27985 C                P1(7)        virtuality of Pomeron (neg, GeV**2)
27986 C                P2           massive 4 momentum of second particle
27987 C                IMODE        1   diffraction dissociation
27988 C                             2   double-pomeron scattering
27989 C
27990 C     output:    IPOSH1,2     index of the particles in /POEVT1/
27991 C                IREJ         0  successful string construction
27992 C                             1  no string construction possible
27993 C
27994 C***********************************************************************
27995       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27996       SAVE
27997
27998       DIMENSION P1(7),P2(7)
27999
28000       PARAMETER ( EPS  = 1.D-7,
28001      &            DEPS = 1.D-10)
28002
28003 C  input/output channels
28004       INTEGER LI,LO
28005       COMMON /POINOU/ LI,LO
28006 C  event debugging information
28007       INTEGER NMAXD
28008       PARAMETER (NMAXD=100)
28009       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28010      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28011       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28012      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28013 C  internal rejection counters
28014       INTEGER NMXJ
28015       PARAMETER (NMXJ=60)
28016       CHARACTER*10 REJTIT
28017       INTEGER IFAIL
28018       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28019 C  c.m. kinematics of diffraction
28020       INTEGER NPOSD
28021       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28022      &                 SIDD,CODD,SIFD,COFD,PDCMS
28023       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28024      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28025 C  model switches and parameters
28026       CHARACTER*8 MDLNA
28027       INTEGER ISWMDL,IPAMDL
28028       DOUBLE PRECISION PARMDL
28029       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28030 C  some constants
28031       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28032       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28033      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28034 C  standard particle data interface
28035       INTEGER NMXHEP
28036       PARAMETER (NMXHEP=4000)
28037       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28038       DOUBLE PRECISION PHEP,VHEP
28039       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28040      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28041      &                VHEP(4,NMXHEP)
28042 C  extension to standard particle data interface (PHOJET specific)
28043       INTEGER IMPART,IPHIST,ICOLOR
28044       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28045
28046       DIMENSION PCH1(2,4)
28047       data IC1 /0/
28048       data IC2 /0/
28049
28050       IREJ = 0
28051       ILTR1 = NHEP+1
28052       IGEN = IGENM
28053       if(IGENM.le.-10) IGEN = 0
28054
28055 C  elastic part
28056       IF(IPAR.EQ.0) THEN
28057         IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28058           if(IGEN.eq.0) IGEN = 3
28059 C  pi+/pi- isotropic background
28060           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28061      &      P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28062           CALL PHO_SDECAY(IPOSH1,0,-2)
28063         ELSE
28064           if(IGEN.eq.0) then
28065             IGEN = 2
28066             if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28067           endif
28068 C  registration of particle or resonance
28069           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28070      &      P1(4),0,IGEN,0,0,IPOSH1,1)
28071         ENDIF
28072
28073 C  diffraction dissociation
28074       ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28075 C  calculation of resulting particle momenta
28076         IF(IMOTH1.EQ.NPOSD(1)) THEN
28077           K = 2
28078         ELSE
28079           K = 1
28080         ENDIF
28081         DO 100 I=1,4
28082           PCH1(2,I) = PDCMS(I,K)-P2(I)
28083           PCH1(1,I) = P1(I)-PCH1(2,I)
28084  100    CONTINUE
28085
28086 C  registration
28087         if(IMODE.LT.2) then
28088           if(IGEN.eq.0) IGEN = -IGENM/10+4
28089           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28090      &      PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28091         else
28092           if(IGEN.eq.0) IGEN = 4
28093         endif
28094         CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28095      &    PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28096
28097 C  invalid IPAR
28098       ELSE
28099         WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28100         CALL PHO_ABORT
28101       ENDIF
28102
28103 C  back transformation
28104       CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28105      &  GAMBED(1),GAMBED(2),GAMBED(3))
28106
28107       END
28108
28109 *$ CREATE PHO_QELAST.FOR
28110 *COPY PHO_QELAST
28111 CDECK  ID>, PHO_QELAST
28112       SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28113 C**********************************************************************
28114 C
28115 C     sampling of quasi elastic processes
28116 C
28117 C     input:   IPROC  2   purely elastic scattering
28118 C              IPROC  3   q-ela. omega/omega/phi/pi+pi- production
28119 C              IPROC  4   double pomeron scattering
28120 C              IPROC  -1  initialization
28121 C              IPROC  -2  output of statistics
28122 C              JM1/2      index of initial particle 1/2
28123 C
28124 C     output:  initial and final particles in /POEVT1/ involving
28125 C              polarized resonances in /POEVT1/ and decay
28126 C              products
28127 C
28128 C              IREJ    0  successful
28129 C                      1  failure
28130 C                     50  user rejection
28131 C
28132 C**********************************************************************
28133       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28134       SAVE
28135
28136       PARAMETER ( NTAB = 20,
28137      &            EPS  = 1.D-10,
28138      &            PIMASS = 0.13D0,
28139      &            DEPS = 1.D-10)
28140
28141 C  input/output channels
28142       INTEGER LI,LO
28143       COMMON /POINOU/ LI,LO
28144 C  event debugging information
28145       INTEGER NMAXD
28146       PARAMETER (NMAXD=100)
28147       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28148      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28149       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28150      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28151 C  global event kinematics and particle IDs
28152       INTEGER IFPAP,IFPAB
28153       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28154       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28155 C  c.m. kinematics of diffraction
28156       INTEGER NPOSD
28157       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28158      &                 SIDD,CODD,SIFD,COFD,PDCMS
28159       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28160      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28161 C  model switches and parameters
28162       CHARACTER*8 MDLNA
28163       INTEGER ISWMDL,IPAMDL
28164       DOUBLE PRECISION PARMDL
28165       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28166 C  some constants
28167       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28168       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28169      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28170 C  cross sections
28171       INTEGER IPFIL,IFAFIL,IFBFIL
28172       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28173      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28174      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28175      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28176      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28177       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28178      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28179      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28180      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28181      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28182      &                IPFIL,IFAFIL,IFBFIL
28183 C  standard particle data interface
28184       INTEGER NMXHEP
28185       PARAMETER (NMXHEP=4000)
28186       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28187       DOUBLE PRECISION PHEP,VHEP
28188       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28189      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28190      &                VHEP(4,NMXHEP)
28191 C  extension to standard particle data interface (PHOJET specific)
28192       INTEGER IMPART,IPHIST,ICOLOR
28193       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28194
28195       DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28196       DIMENSION   P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28197       DIMENSION   IFL(2),IDPRO(4)
28198       character*15 pho_pname
28199       CHARACTER*8  VMESA(0:4),VMESB(0:4)
28200       DIMENSION   ISAMVM(4,4)
28201       DATA IDPRO / 113,223,333,92 /
28202       DATA VMESA / 'vmeson  ','rho     ','omega   ','phi     ',
28203      &             'pi+pi-  ' /
28204       DATA VMESB / 'vmeson  ','rho     ','omega   ','phi     ',
28205      &             'pi+pi-  ' /
28206
28207 C  sampling of elastic/quasi-elastic processes
28208       IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28209         IREJ = 0
28210         NPOSD(1) = JM1
28211         NPOSD(2) = JM2
28212         DO 55 I=1,2
28213           PMI(I) = PHEP(5,NPOSD(I))
28214           IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28215  55     CONTINUE
28216 C  get CM system
28217         PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28218         PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28219         PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28220         PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28221         SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28222         ECMD = SQRT(SS)
28223
28224         IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28225           IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28226      &      'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28227      &      ECMD,PMI
28228           IREJ = 5
28229           RETURN
28230         ENDIF
28231
28232         DO 60 I=1,4
28233           GAMBED(I) = PK1(I)/ECMD
28234  60     CONTINUE
28235         CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28236      &           PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28237      &           PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28238 C  rotation angles
28239         CODD = PK1(3)/PTOT1
28240         SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28241         COFD = 1.D0
28242         SIFD = 0.D0
28243         IF(PTOT1*SIDD.GT.1.D-5) THEN
28244           COFD = PK1(1)/(SIDD*PTOT1)
28245           SIFD = PK1(2)/(SIDD*PTOT1)
28246           ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28247           COFD = COFD/ANORF
28248           SIFD = SIFD/ANORF
28249         ENDIF
28250 C  get CM momentum
28251         AM12 = PMI(1)**2
28252         AM22 = PMI(2)**2
28253         PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28254
28255 C  production process of mother particles
28256         IGEN = IPHIST(2,NPOSD(1))
28257         if(IGEN.eq.0) IGEN = IPROC
28258
28259         ICALL = ICALL + 1
28260 C  main rejection label
28261  50     CONTINUE
28262 C  determine process and final particles
28263         IFL(1) = IDHEP(NPOSD(1))
28264         IFL(2) = IDHEP(NPOSD(2))
28265         IF(IPROC.EQ.3) THEN
28266           ITRY = 0
28267  100      CONTINUE
28268           ITRY = ITRY+1
28269           IF(ITRY.GT.50) THEN
28270             IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28271      &        'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28272      &        ITRY,ECMD
28273             IREJ = 5
28274             RETURN
28275           ENDIF
28276           XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28277           DO 110 I=1,4
28278             DO 120 J=1,4
28279               XI = XI-SIGVM(I,J)
28280               IF(XI.LE.0.D0) GOTO 130
28281  120        CONTINUE
28282  110      CONTINUE
28283  130      CONTINUE
28284           IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28285           IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28286           ISAMVM(I,J) = ISAMVM(I,J)+1
28287           ISAMQE = ISAMQE+1
28288 C  sample new masses
28289           CALL PHO_SAMASS(IFL(1),RMASS(1))
28290           CALL PHO_SAMASS(IFL(2),RMASS(2))
28291           IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28292         ELSE IF(IPROC.EQ.2) THEN
28293           I = 0
28294           J = 0
28295           ISAMEL = ISAMEL+1
28296           RMASS(1) = PHO_PMASS(NPOSD(1),2)
28297           RMASS(2) = PHO_PMASS(NPOSD(2),2)
28298         ELSE
28299           WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28300           CALL PHO_ABORT
28301         ENDIF
28302 C  sample momentum transfer
28303         CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28304      &    SLWGHT,IREJ)
28305         IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28306      &    'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28307 C  calculate new momenta
28308         CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28309         IF(IREJ.NE.0) GOTO 50
28310         DO K=1,4
28311           P(K,1) = PK1(K)
28312           P(K,2) = PK2(K)
28313         ENDDO
28314 C  comment line for elastic/quasi-elastic scattering
28315         CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28316      &    TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28317
28318         I1 = NHEP+1
28319 C  fill /POEVT1/
28320         DO 200 I=1,2
28321           K = 3-I
28322           IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28323 C  pi+/pi- isotropic background
28324             IGEN = 3
28325             CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28326      &        P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28327             ICOLOR(I,ICPOS) = IPOS
28328             CALL PHO_SDECAY(IPOS,0,-2)
28329           ELSE
28330 C  registration
28331             IGEN = 2
28332             if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28333             CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28334      &        P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28335             ICOLOR(I,ICPOS) = IPOS
28336           ENDIF
28337  200    CONTINUE
28338         I2 = NHEP
28339 C  search for vector mesons
28340         DO 300 I=I1,I2
28341 C  decay according to polarization
28342           IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28343             ISP = IPAMDL(3)
28344             IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28345             CALL PHO_SDECAY(I,ISP,2)
28346           ENDIF
28347  300    CONTINUE
28348         I2 = NHEP
28349 C  back transformation
28350         CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28351      &              GAMBED(2),GAMBED(3))
28352
28353 C  initialization of tables
28354       ELSE IF(IPROC.EQ.-1) THEN
28355         DO 10 I=1,4
28356           DO 20 J=1,4
28357             ISAMVM(I,J) = 0
28358  20       CONTINUE
28359  10     CONTINUE
28360         ISAMEL = 0
28361         ISAMQE = 0
28362         IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28363         IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28364         CALL PHO_SAMASS(-1,RMASS(1))
28365         ICALL = 0
28366
28367 C  output of statistics
28368       ELSE IF(IPROC.EQ.-2) THEN
28369         IF(ICALL.LT.10) RETURN
28370         WRITE(LO,'(/,1X,A,I10/,1X,A)')
28371      &    'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28372      &    '---------------------------------------------------'
28373         WRITE(LO,'(1X,A,I10)')
28374      &    'sampled elastic processes:',ISAMEL
28375         WRITE(LO,'(1X,A,I10)')
28376      &    'sampled quasi-elastic vectormeson production:',ISAMQE
28377         WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28378         DO 30 I=1,4
28379           WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28380  30     CONTINUE
28381         CALL PHO_SAMASS(-2,RMASS(1))
28382       ELSE
28383         WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28384      &    'unknown process ID',IPROC
28385         CALL PHO_ABORT
28386       ENDIF
28387
28388       END
28389
28390 *$ CREATE PHO_CDIFF.FOR
28391 *COPY PHO_CDIFF
28392 CDECK  ID>, PHO_CDIFF
28393       SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28394 C**********************************************************************
28395 C
28396 C     preparation of /POEVT1/ for double-pomeron scattering
28397 C
28398 C     input:   IMOTH1/2   index of mother particles in /POEVT1/
28399 C
28400 C              IMODE   1  sampling of pomeron-pomeron scattering
28401 C                     -1  initialization
28402 C                     -2  output of statistics
28403 C
28404 C     output:   MSOFT     number of generated soft strings
28405 C               MHARD     number of generated hard strings
28406 C               IREJ      0  accepted
28407 C                         1  rejected
28408 C                        50  user rejection
28409 C
28410 C**********************************************************************
28411       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28412       SAVE
28413
28414       PARAMETER ( EPS  = 1.D-10,
28415      &            DEPS = 1.D-10)
28416
28417 C  input/output channels
28418       INTEGER LI,LO
28419       COMMON /POINOU/ LI,LO
28420 C  event debugging information
28421       INTEGER NMAXD
28422       PARAMETER (NMAXD=100)
28423       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28424      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28425       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28426      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28427 C  internal rejection counters
28428       INTEGER NMXJ
28429       PARAMETER (NMXJ=60)
28430       CHARACTER*10 REJTIT
28431       INTEGER IFAIL
28432       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28433 C  model switches and parameters
28434       CHARACTER*8 MDLNA
28435       INTEGER ISWMDL,IPAMDL
28436       DOUBLE PRECISION PARMDL
28437       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28438 C  general process information
28439       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28440       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28441 C  Reggeon phenomenology parameters
28442       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28443      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28444       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28445      &                ALREG,ALREGP,GR(2),B0REG(2),
28446      &                GPPP,GPPR,B0PPP,B0PPR,
28447      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28448 C  parameters of 2x2 channel model
28449       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28450       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28451 C  some constants
28452       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28453       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28454      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28455 C  energy-interpolation table
28456       INTEGER IEETA2
28457       PARAMETER ( IEETA2 = 20 )
28458       INTEGER ISIMAX
28459       DOUBLE PRECISION SIGTAB,SIGECM
28460       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28461 C  table of particle indices for recursive PHOJET calls
28462       INTEGER MAXIPX
28463       PARAMETER ( MAXIPX = 100 )
28464       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28465       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28466      &                IPOIX1,IPOIX2,IPOIX3
28467 C  standard particle data interface
28468       INTEGER NMXHEP
28469       PARAMETER (NMXHEP=4000)
28470       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28471       DOUBLE PRECISION PHEP,VHEP
28472       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28473      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28474      &                VHEP(4,NMXHEP)
28475 C  extension to standard particle data interface (PHOJET specific)
28476       INTEGER IMPART,IPHIST,ICOLOR
28477       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28478
28479       DIMENSION PD(4)
28480
28481       if(IMODE.ne.1) return
28482
28483       IREJ = 0
28484       IP = 4
28485 C  select first diffraction
28486       IF(DT_RNDM(DUM).GT.0.5D0) THEN
28487         IPAR1 = 1
28488         IPAR2 = 0
28489       ELSE
28490         IPAR1 = 0
28491         IPAR2 = 1
28492       ENDIF
28493       ITRY2 = 0
28494       ITRYM = 1000
28495
28496 C  save current status
28497       MSOFT = 0
28498       MHARD = 0
28499       KHPOMS = KHPOM
28500       KSPOMS = KSPOM
28501       KSREGS = KSREG
28502       KHDIRS = KHDIR
28503       IPOIS1 = IPOIX1
28504       IPOIS2 = IPOIX2
28505       IPOIS3 = IPOIX3
28506       JDA11 = JDAHEP(1,IMOTH1)
28507       JDA21 = JDAHEP(2,IMOTH1)
28508       JDA12 = JDAHEP(1,IMOTH2)
28509       JDA22 = JDAHEP(2,IMOTH2)
28510       ISTH1 = ISTHEP(IMOTH1)
28511       ISTH2 = ISTHEP(IMOTH2)
28512       NHEPS = NHEP
28513
28514 C  find mother particle production process
28515       IGEN = IPHIST(2,IMOTH1)
28516       if(IGEN.eq.0) IGEN = 4
28517
28518 C  main generation loop
28519  60   CONTINUE
28520
28521       KSPOM = KSPOMS
28522       KHPOM = KHPOMS
28523       KHDIR = KHDIRS
28524       KSREG = KSREGS
28525       I1 = IPAR1
28526       I2 = IPAR2
28527 C  reset mother-daugther relations
28528       NHEP = NHEPS
28529       JDAHEP(1,IMOTH1) = JDA11
28530       JDAHEP(2,IMOTH1) = JDA21
28531       JDAHEP(1,IMOTH2) = JDA12
28532       JDAHEP(2,IMOTH2) = JDA22
28533       ISTHEP(IMOTH1) = ISTH1
28534       ISTHEP(IMOTH2) = ISTH2
28535       IPOIX1 = IPOIS1
28536       IPOIX2 = IPOIS2
28537       IPOIX3 = IPOIS3
28538 C  rejection counter
28539       ITRY2 = ITRY2+1
28540       IF(ITRY2.GT.1) THEN
28541         IFAIL(39) = IFAIL(39)+1
28542         IF(ITRY2.GE.ITRYM) GOTO 50
28543       ENDIF
28544 C  generate two diffractive events
28545       CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28546       IF(IREJ.NE.0) GOTO 50
28547       CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28548       IF(IREJ.NE.0) GOTO 50
28549 C  mass of pomeron-pomeron system
28550       DO 100 I2 = NHEP,1,-1
28551         IF(IDHEP(I2).EQ.990) GOTO 110
28552  100  CONTINUE
28553  110  CONTINUE
28554       DO 120 I1 = I2-1,1,-1
28555         IF(IDHEP(I1).EQ.990) GOTO 130
28556  120  CONTINUE
28557  130  CONTINUE
28558       DO 140 I=1,4
28559         PD(I) = PHEP(I,I1)+PHEP(I,I2)
28560  140  CONTINUE
28561       XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28562       IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28563      &  'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28564       IF(XMASS.LT.0.1D0) GOTO 60
28565       XMASS = SQRT(XMASS)
28566       IF(XMASS.LT.PARMDL(71)) GOTO 60
28567
28568 C  sample pomeron-pomeron interaction process
28569       CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28570      &            IPROC,ISAM,JSAM,KSAM,IDIR)
28571
28572 C  non-diffractive pomeron-pomeron interactions
28573       IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28574  200    CONTINUE
28575         IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28576 C  debug output
28577         IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28578      &    'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28579      &    IP,XMASS,ISAM,JSAM,KSAM,IDIR
28580 C  store debug information
28581         IF(IDIR.GT.0) THEN
28582           IPAR = 4
28583         ELSE IF(KSAM.GT.0) THEN
28584           IPAR = 3
28585         ELSE IF(ISAM.GT.0) THEN
28586           IPAR = 2
28587         ELSE
28588           IPAR = 1
28589         ENDIF
28590         IDDPOM = IPAR
28591         IF(ISAM+JSAM.GT.0) KSDPO = 1
28592         IF(KSAM+IDIR.GT.0) KHDPO = 1
28593         KSPOM = ISAM
28594         KSREG = JSAM
28595         KHPOM = KSAM
28596         KHDIR = IDIR
28597         KSTRG = 0
28598         KSLOO = 0
28599 C  generate pomeron-pomeron interaction
28600         CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28601         IF(IREJ.NE.0) THEN
28602           IFAIL(3) = IFAIL(3)+1
28603           IF(IPAR.GT.1) THEN
28604             IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28605             IF(IDIR.GT.0) THEN
28606               IFAIL(10) = IFAIL(10)+1
28607               IDIR = 0
28608             ELSE IF(KSAM.GT.0) THEN
28609               KSAM = KSAM-1
28610             ELSE IF(ISAM.GT.0) THEN
28611               ISAM = ISAM-1
28612             ENDIF
28613             GOTO 200
28614           ELSE
28615             IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28616      &        'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28617      &        I,IPAR,XMASS
28618             GOTO 50
28619           ENDIF
28620         ENDIF
28621
28622 C  diffractive pomeron-pomeron interactions
28623       ELSE
28624         IPOIX2 = IPOIX2+1
28625         IPORES(IPOIX2)   = IPROC
28626         IPOPOS(1,IPOIX2) = I1
28627         IPOPOS(2,IPOIX2) = I2
28628         IPAR = 10+IPROC
28629         IDDPOM = IPAR
28630       ENDIF
28631
28632 C  update debug information
28633       KSPOM = KSPOMS+ISAM
28634       KSREG = KSREGS+JSAM
28635       KHPOM = KHPOMS+KSAM
28636       KHDIR = KHDIRS+IDIR
28637 C  comment line for central diffraction
28638       CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28639      &            I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28640       PHEP(5,IPOS) = XMASS
28641 C  debug output
28642       IF(IDEB(59).GE.15) THEN
28643         WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28644      &                        '-----------------------------'
28645         CALL PHO_PREVNT(0)
28646       ENDIF
28647       RETURN
28648
28649 C  treatment of rejection
28650  50   CONTINUE
28651       IREJ = 1
28652       IFAIL(40) = IFAIL(40)+1
28653       IF(IDEB(59).GE.3) THEN
28654         WRITE(LO,'(1X,A)')
28655      &    'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28656         IF(IDEB(59).GE.10) THEN
28657           CALL PHO_PREVNT(0)
28658         ELSE
28659           CALL PHO_PREVNT(-1)
28660         ENDIF
28661       ENDIF
28662
28663       END
28664
28665 *$ CREATE PHO_SAMASS.FOR
28666 *COPY PHO_SAMASS
28667 CDECK  ID>, PHO_SAMASS
28668       SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28669 C**********************************************************************
28670 C
28671 C     resonance mass sampling of quasi elastic processes
28672 C
28673 C     input:   IFLA       PDG number of particle
28674 C              IFLA   -1  initialization
28675 C              IFLA   -2  output of statistics
28676 C
28677 C     output:  RMASS      particle mass (in GeV)
28678 C
28679 C**********************************************************************
28680       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28681       SAVE
28682
28683       PARAMETER(EPS  = 1.D-10 )
28684
28685 C  input/output channels
28686       INTEGER LI,LO
28687       COMMON /POINOU/ LI,LO
28688 C  event debugging information
28689       INTEGER NMAXD
28690       PARAMETER (NMAXD=100)
28691       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28692      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28693       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28694      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28695 C  model switches and parameters
28696       CHARACTER*8 MDLNA
28697       INTEGER ISWMDL,IPAMDL
28698       DOUBLE PRECISION PARMDL
28699       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28700 C  parameters of the "simple" Vector Dominance Model
28701       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28702       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28703
28704       PARAMETER(NTABM=50)
28705       DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28706       DIMENSION SUM(4),ICALL(4)
28707
28708 C*****************************************************************
28709 C  initialization of tables
28710       IF(IFLA.EQ.-1) THEN
28711 C
28712         NSTEP = NTABM
28713         DO 102 I=1,4
28714           ICALL(I) = 0
28715           DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28716           DO 105 K=1,NSTEP
28717             RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28718  105      CONTINUE
28719  102    CONTINUE
28720 C  calculate table of dsig/dm
28721         CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28722 C  output of table
28723         IF(IDEB(35).GE.1) THEN
28724           WRITE(LO,'(/5X,A)') 'table:   mass (GeV)  DSIG/DM (mub/GeV)'
28725           WRITE(LO,'(1X,A,/1X,A)')
28726      &      '  (m,  rho,     m,  omega,      m,   phi,    m,  pi+pi-)',
28727      &      ' -------------------------------------------------------'
28728           DO 106 K=1,NSTEP
28729             WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28730      &        RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28731  106      CONTINUE
28732         ENDIF
28733 C  make second table for sampling
28734         DO 109 I=1,4
28735           SUM(I) = 0.D0
28736           DO 108 K=2,NSTEP
28737             SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
28738             XMC(I,K) = SUM(I)
28739  108      CONTINUE
28740  109    CONTINUE
28741 C  normalization
28742         DO 118 K=1,NSTEP
28743           DO 119 I=1,4
28744             XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
28745  119      CONTINUE
28746  118    CONTINUE
28747         IF(IDEB(35).GE.10) THEN
28748           WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
28749           WRITE(LO,'(1X,A,/1X,A)')
28750      &      '  (m,  rho,     m,  omega,      m,   phi,    m,  pi+pi-)',
28751      &      ' -------------------------------------------------------'
28752           DO 120 K=1,NSTEP
28753             WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
28754      &        RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
28755  120      CONTINUE
28756         ENDIF
28757 C
28758 C**************************************************
28759 C  output of statistics
28760       ELSE IF(IFLA.EQ.-2) THEN
28761         WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
28762      &                        '----------------------'
28763         WRITE(LO,'(4(/8X,A,I10))') 'rho:   ',ICALL(1),
28764      &    'omega: ',ICALL(2),'phi:   ',ICALL(3),'pi+pi-:',ICALL(4)
28765 C
28766 C********************************************************
28767 C  sampling of RMASS
28768       ELSE
28769 C  quasi-elastic vector meson production
28770         IF(IFLA.EQ.113) THEN
28771           KP = 1
28772         ELSE IF(IFLA.EQ.223) THEN
28773           KP = 2
28774         ELSE IF(IFLA.EQ.333) THEN
28775           KP = 3
28776         ELSE IF(IFLA.EQ.92) THEN
28777           KP = 4
28778 C  quasi-elastic production of h*
28779         ELSE IF(IFLA.EQ.91) THEN
28780           RMASS = 0.35D0
28781           RETURN
28782 C  elastic hadron scattering
28783         ELSE
28784           RMASS = PHO_PMASS(IFLA,1)
28785           IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
28786      &      'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
28787           RETURN
28788         ENDIF
28789 C
28790 C  sample mass of vector mesonsn / two-pi background
28791         XI = DT_RNDM(RMASS) + EPS
28792 C  binary search
28793         IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
28794           KMIN=1
28795           KMAX=NSTEP
28796  300      CONTINUE
28797           IF((KMAX-KMIN).EQ.1) GOTO 400
28798           KK=(KMAX+KMIN)/2
28799           IF(XI.LE.XMC(KP,KK)) THEN
28800             KMAX=KK
28801           ELSE
28802             KMIN=KK
28803           ENDIF
28804           GOTO 300
28805  400      CONTINUE
28806         ELSE
28807           WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
28808           WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
28809      &      KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
28810           CALL PHO_ABORT
28811         ENDIF
28812 C  fine interpolation
28813         RMASS = RMA(KP,KMIN)+
28814      &          (RMA(KP,KMAX)-RMA(KP,KMIN))/
28815      &          (XMC(KP,KMAX)-XMC(KP,KMIN))
28816      &          *(XI-XMC(KP,KMIN))
28817         IF(IDEB(35).GE.20) THEN
28818           IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
28819      &      'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
28820      &      RMA(KP,KMIN),RMA(KP,KMAX),RMASS
28821           WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
28822      &      IFLA,RMASS
28823         ENDIF
28824         ICALL(KP) = ICALL(KP)+1
28825       ENDIF
28826       END
28827
28828 *$ CREATE PHO_DSIGDM.FOR
28829 *COPY PHO_DSIGDM
28830 CDECK  ID>, PHO_DSIGDM
28831       SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
28832 C**********************************************************************
28833 C
28834 C     differential cross section DSIG/DM of low mass enhancement
28835 C
28836 C     input:   RMA(4,NTABM)   mass values
28837 C     output:  XMA(4,NTABM)   DSIG/DM of resonances
28838 C                  1          rho production
28839 C                  2          omega production
28840 C                  3          phi production
28841 C                  4          pi-pi continuum
28842 C
28843 C**********************************************************************
28844       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28845       SAVE
28846
28847       PARAMETER ( EPS  = 1.D-10 )
28848
28849       PARAMETER(NTABM=50)
28850       DIMENSION XMA(4,NTABM),RMA(4,NTABM)
28851
28852 C  input/output channels
28853       INTEGER LI,LO
28854       COMMON /POINOU/ LI,LO
28855 C  event debugging information
28856       INTEGER NMAXD
28857       PARAMETER (NMAXD=100)
28858       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28859      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28860       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28861      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28862 C  model switches and parameters
28863       CHARACTER*8 MDLNA
28864       INTEGER ISWMDL,IPAMDL
28865       DOUBLE PRECISION PARMDL
28866       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28867 C  parameters of the "simple" Vector Dominance Model
28868       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28869       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28870
28871       PIMASS = 0.135
28872 C  rho meson shape (mass dependent width)
28873       QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
28874       DO 100 I=1,NSTEP
28875         XMASS = RMA(1,I)
28876         QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
28877         GAMMA = GAMM(1)*(QQ/QRES)**3
28878         XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
28879      &             /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
28880  100  CONTINUE
28881 C  omega/phi meson (constant width)
28882       DO 200 K=2,3
28883         DO 300 I=1,NSTEP
28884           XMASS = RMA(K,I)
28885           XMA(K,I) = XMASS*GAMM(K)
28886      &               /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
28887  300    CONTINUE
28888  200  CONTINUE
28889 C  pi-pi continuum
28890       DO 400 I=1,NSTEP
28891         XMASS = RMA(4,I)
28892         XMA(4,I) = (XMASS-0.29D0)**2/XMASS
28893  400  CONTINUE
28894
28895       END
28896
28897 *$ CREATE PHO_SDECAY.FOR
28898 *COPY PHO_SDECAY
28899 CDECK  ID>, PHO_SDECAY
28900       SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
28901 C**********************************************************************
28902 C
28903 C     decay of single resonance of /POEVT1/:
28904 C       decay in helicity frame according to polarization, isotropic
28905 C       decay and decay with limited transverse phase space possible
28906 C
28907 C     ATTENTION:
28908 C     reference to particle number of CPC has to exist
28909 C
28910 C     input:   NPOS    position in /POEVT1/
28911 C              ISP     0  decay according to phase space
28912 C                      1  decay according to transversal polarization
28913 C                      2  decay according to longitudinal polarization
28914 C                      3  decay with limited phase space
28915 C              ILEV    decay mode to use
28916 C                      1 strong only
28917 C                      2 strong and ew of tau, charm, and bottom
28918 C                      3 strong and electro-weak decays
28919 C                      negative: remove mother resonance after decay
28920 C
28921 C     output:  /POEVT1/,/POEVT2/ final particles according to decay mode
28922 C
28923 C**********************************************************************
28924       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28925       SAVE
28926
28927       PARAMETER ( EPS  = 1.D-15,
28928      &            DEPS = 1.D-10 )
28929
28930 C  input/output channels
28931       INTEGER LI,LO
28932       COMMON /POINOU/ LI,LO
28933 C  event debugging information
28934       INTEGER NMAXD
28935       PARAMETER (NMAXD=100)
28936       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28937      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28938       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28939      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28940 C  model switches and parameters
28941       CHARACTER*8 MDLNA
28942       INTEGER ISWMDL,IPAMDL
28943       DOUBLE PRECISION PARMDL
28944       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28945 C  some constants
28946       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28947       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28948      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28949 C  standard particle data interface
28950       INTEGER NMXHEP
28951       PARAMETER (NMXHEP=4000)
28952       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28953       DOUBLE PRECISION PHEP,VHEP
28954       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28955      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28956      &                VHEP(4,NMXHEP)
28957 C  extension to standard particle data interface (PHOJET specific)
28958       INTEGER IMPART,IPHIST,ICOLOR
28959       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28960 C  general particle data
28961       double precision xm_list,tau_list,gam_list,
28962      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
28963      &  xm_bb82_list,xm_bb102_list
28964       integer          ich3_list,iba3_list,iq_list,
28965      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
28966       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
28967      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
28968      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
28969      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
28970      &  ich3_list(300),iba3_list(300),iq_list(3,300),
28971      &  id_psm_list(6,6),id_vem_list(6,6),
28972      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
28973 C  particle decay data
28974       double precision wg_sec_list
28975       integer          idec_list,isec_list
28976       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
28977      &  isec_list(3,500)
28978 C  auxiliary data for three particle decay
28979       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
28980       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
28981
28982       DIMENSION WGHD(20),KCH(20),ID(3)
28983
28984       IMODE = ABS(ILEV)
28985       IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
28986      &  'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
28987
28988 C  comment entry
28989       IF(ISTHEP(NPOS).GT.11) RETURN
28990
28991 C  particle stable?
28992       IDcpc = IMPART(NPOS)
28993       IF(IDcpc.EQ.0) return
28994       IDabs = iabs(IDcpc)
28995       if(idec_list(1,IDabs).eq.0) return
28996
28997 C  different decay modi (times)
28998       IF(IMODE.EQ.1) THEN
28999         if(idec_list(1,IDabs).ne.1) return
29000       ELSE IF(IMODE.EQ.2) THEN
29001         if(idec_list(1,IDabs).gt.2) return
29002       ELSE IF(IMODE.EQ.3) THEN
29003         if(idec_list(1,IDabs).gt.3) return
29004       ELSE
29005         WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
29006         CALL PHO_ABORT
29007       ENDIF
29008
29009 C  decay products, check for mass limitations
29010       K = 0
29011       WGSUM = 0.D0
29012       AMIST = PHEP(5,NPOS)
29013       DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
29014         AMSUM = 0.D0
29015         DO 200 L=1,3
29016           ID(L) = isec_list(L,I)
29017           IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
29018  200    CONTINUE
29019         IF(AMSUM.LT.AMIST) THEN
29020           K = K+1
29021           WGHD(K) = wg_sec_list(I)
29022           KCH(K) = I
29023         ENDIF
29024  100  CONTINUE
29025       IF(K.EQ.0)THEN
29026         WRITE(LO,'(/1X,A,I6,3E12.4)')
29027      &    'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29028      &    NPOS,AMIST,AMSUM
29029         CALL PHO_PREVNT(0)
29030         RETURN
29031       ENDIF
29032
29033 C  sample new decay channel
29034       XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29035       K = 0
29036       WGSUM = 0.D0
29037  500  CONTINUE
29038         K = K+1
29039         WGSUM = WGSUM+WGHD(K)
29040       IF(XI.GT.WGSUM) GOTO 500
29041       IK = KCH(K)
29042       ID(1) = isec_list(1,IK)
29043       ID(2) = isec_list(2,IK)
29044       ID(3) = isec_list(3,IK)
29045       if(IDcpc.lt.0) then
29046         ID(1) = ipho_anti(ID(1))
29047         ID(2) = ipho_anti(ID(2))
29048         if(ID(3).ne.0) ID(3) = ipho_anti(ID(3))
29049       endif
29050
29051 C  rotation
29052       PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29053       CXS = PHEP(1,NPOS)/PTOT
29054       CYS = PHEP(2,NPOS)/PTOT
29055       CZS = PHEP(3,NPOS)/PTOT
29056 C  boost
29057       GBET = PTOT/AMIST
29058       GAM = PHEP(4,NPOS)/AMIST
29059
29060       IF(ID(3).EQ.0) THEN
29061 C  two particle decay
29062         CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29063       ELSE
29064 C  three particle decay
29065         CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29066      &    pho_pmass(ID(3),0),ISP)
29067       ENDIF
29068
29069       IF(ILEV.LT.0) THEN
29070         IF(NHEP.NE.NPOS) THEN
29071           WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29072      &      'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29073           CALL PHO_ABORT
29074         ENDIF
29075         IMO1 = JMOHEP(1,NPOS)
29076         IMO2 = JMOHEP(2,NPOS)
29077         NHEP = NHEP-1
29078       ELSE
29079         IMO1 = NPOS
29080         IMO2 = 0
29081       ENDIF
29082       IPH1 = IPHIST(1,NPOS)
29083       IPH2 = IPHIST(2,NPOS)
29084
29085 C  back transformation and registration
29086       DO 300 I=1,3
29087         IF(ID(I).NE.0) THEN
29088           CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29089      &      PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29090           XX = PTOT*CX
29091           YY = PTOT*CY
29092           ZZ = PTOT*CZ
29093           CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29094      &      IPH1,IPH2,0,0,IPOS,1)
29095         ENDIF
29096  300  CONTINUE
29097
29098  400  CONTINUE
29099 C  debug output
29100       IF(IDEB(36).GE.20) THEN
29101         WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29102      &                        '--------------------'
29103         CALL PHO_PREVNT(0)
29104       ENDIF
29105
29106       END
29107
29108 *$ CREATE PHO_SDECY2.FOR
29109 *COPY PHO_SDECY2
29110 CDECK  ID>, PHO_SDECY2
29111       SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29112 C**********************************************************************
29113 C
29114 C     isotropic/anisotropic two particle decay in CM system,
29115 C     (transversely/longitudinally polarized boson into two
29116 C     pseudo-scalar mesons)
29117 C
29118 C**********************************************************************
29119       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29120       SAVE
29121
29122 C  input/output channels
29123       INTEGER LI,LO
29124       COMMON /POINOU/ LI,LO
29125 C  auxiliary data for three particle decay
29126       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29127       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29128
29129       UMO2=UMO*UMO
29130       AM11=AM1*AM1
29131       AM22=AM2*AM2
29132       ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29133       ECM(2)=UMO-ECM(1)
29134       WAU=ECM(1)*ECM(1)-AM11
29135       IF(WAU.LT.0.D0) THEN
29136         WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29137         CALL PHO_ABORT
29138       ENDIF
29139       PCM(1)=SQRT(WAU)
29140       PCM(2)=PCM(1)
29141
29142       CALL PHO_SFECFE(SIF(1),COF(1))
29143       IF(ISP.EQ.0) THEN
29144 C  no polarization
29145         COD(1)  = 2.D0*DT_RNDM(UMO)-1.D0
29146       ELSE IF(ISP.EQ.1) THEN
29147 C  transverse polarization
29148  400    CONTINUE
29149           COD(1)  = 2.D0*DT_RNDM(AM22)-1.D0
29150           SID12 = 1.D0-COD(1)*COD(1)
29151         IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29152       ELSE IF(ISP.EQ.2) THEN
29153 C  longitudinal polarization
29154  500    CONTINUE
29155           COD(1)  = 2.D0*DT_RNDM(AM2)-1.D0
29156           COD12 = COD(1)*COD(1)
29157         IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29158       ELSE
29159         WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29160      &    'invalid polarization',ISP
29161         CALL PHO_ABORT
29162       ENDIF
29163
29164       COD(2) = -COD(1)
29165       COF(2) = -COF(1)
29166       SIF(2) = -SIF(1)
29167
29168       END
29169
29170 *$ CREATE PHO_SDECY3.FOR
29171 *COPY PHO_SDECY3
29172 CDECK  ID>, PHO_SDECY3
29173       SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29174 C**********************************************************************
29175 C
29176 C     isotropic/anisotropic three particle decay in CM system,
29177 C     (transversely/longitudinally polarized boson into three
29178 C     pseudo-scalar mesons)
29179 C
29180 C**********************************************************************
29181       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29182       SAVE
29183
29184       PARAMETER ( DEPS   = 1.D-30,
29185      &            EPS    = 1.D-15 )
29186
29187 C  input/output channels
29188       INTEGER LI,LO
29189       COMMON /POINOU/ LI,LO
29190 C  auxiliary data for three particle decay
29191       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29192       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29193
29194       DIMENSION F(5),XX(5)
29195
29196 C  calculation of maximum of S2 phase space weight
29197       UMOO=UMO+UMO
29198       GU=(AM2+AM3)**2
29199       GO=(UMO-AM1)**2
29200       UFAK=1.0000000000001D0
29201       IF (GU.GT.GO) UFAK=0.99999999999999D0
29202       OFAK=2.D0-UFAK
29203       GU=GU*UFAK
29204       GO=GO*OFAK
29205       DS2=(GO-GU)/99.D0
29206       AM11=AM1*AM1
29207       AM22=AM2*AM2
29208       AM33=AM3*AM3
29209       UMO2=UMO*UMO
29210       RHO2=0.D0
29211       S22=GU
29212       DO 124 I=1,100
29213         S21=S22
29214         S22=GU+(I-1.D0)*DS2
29215         RHO1=RHO2
29216         RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29217         IF(RHO2.LT.RHO1) GOTO 125
29218   124 CONTINUE
29219
29220   125 CONTINUE
29221       S2SUP=(S22-S21)/2.D0+S21
29222       SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29223      &       /(S2SUP+EPS)
29224       SUPRHO=SUPRHO*1.05D0
29225       XO=S21-DS2
29226       IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29227       IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29228       XX(1)=XO
29229       XX(3)=S22
29230       X1=(XO+S22)*0.5D0
29231       XX(2)=X1
29232       F(3)=RHO2
29233       F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29234       F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29235       DO 126 I=1,16
29236         X4=(XX(1)+XX(2))*0.5D0
29237         X5=(XX(2)+XX(3))*0.5D0
29238         F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29239         F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29240         XX(4)=X4
29241         XX(5)=X5
29242         DO 128 II=1,5
29243           IA=II
29244           DO 131 III=IA,5
29245             IF(F(II).LT.F(III)) THEN
29246               FH=F(II)
29247               F(II)=F(III)
29248               F(III)=FH
29249               FH=XX(II)
29250               XX(II)=XX(III)
29251               XX(III)=FH
29252             ENDIF
29253  131      CONTINUE
29254  128    CONTINUE
29255         SUPRHO=F(1)
29256         S2SUP=XX(1)
29257         DO 129 II=1,3
29258           IA=II
29259           DO 130 III=IA,3
29260             IF (XX(II).LT.XX(III)) THEN
29261               FH=F(II)
29262               F(II)=F(III)
29263               F(III)=FH
29264               FH=XX(II)
29265               XX(II)=XX(III)
29266               XX(III)=FH
29267             ENDIF
29268  130      CONTINUE
29269  129    CONTINUE
29270  126  CONTINUE
29271
29272       AM23=(AM2+AM3)**2
29273
29274 C  selection of S1
29275       ITH=0
29276  200  CONTINUE
29277         ITH=ITH+1
29278         IF(ITH.GT.200) THEN
29279           WRITE(LO,'(/1X,A,I10)')
29280      &      'PHO_SDECY3:ERROR: too many iterations',ITH
29281           CALL PHO_ABORT
29282         ENDIF
29283         S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29284         Y=DT_RNDM(AM23)*SUPRHO
29285         RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29286       IF(Y.GT.RHO) GOTO 200
29287
29288 C  selection of S2
29289       S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29290      &   /(2.D0*S2)-RHO/2.D0
29291       S3=UMO2+AM11+AM22+AM33-S1-S2
29292       ECM(1)=(UMO2+AM11-S2)/UMOO
29293       ECM(2)=(UMO2+AM22-S3)/UMOO
29294       ECM(3)=(UMO2+AM33-S1)/UMOO
29295       PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29296       PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29297       PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29298
29299 C  calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29300       IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29301         COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29302       ELSE
29303         COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29304       ENDIF
29305       COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29306      &        /(2.D0*PCM(2)*PCM(3))
29307       SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29308       SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29309       COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29310
29311 C  selection of the sperical coordinates of particle 3
29312       CALL PHO_SFECFE(SIF(3),COF(3))
29313       IF(ISP.EQ.0) THEN
29314 C  no polarization
29315         COD(3)  = 2.D0*DT_RNDM(S2)-1.D0
29316       ELSE IF(ISP.EQ.1) THEN
29317 C  transverse polarization
29318  400    CONTINUE
29319           COD(3)  = 2.D0*DT_RNDM(S1)-1.D0
29320           SID32 = 1.D0-COD(3)*COD(3)
29321         IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29322       ELSE IF(ISP.EQ.2) THEN
29323 C  longitudinal polarization
29324  500    CONTINUE
29325           COD(3)  = 2.D0*DT_RNDM(COSTH2)-1.D0
29326           COD32 = COD(3)*COD(3)
29327         IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29328       ELSE
29329         WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29330      &    'invalid polarization',ISP
29331         CALL PHO_ABORT
29332       ENDIF
29333
29334 C  selection of the rotation angle of p1-p2 plane along p3
29335       IF(ISP.EQ.0) THEN
29336         CALL PHO_SFECFE(SFE,CFE)
29337       ELSE
29338         SFE = 0.D0
29339         CFE = 1.D0
29340       ENDIF
29341       CX11=-COSTH1
29342       CY11=SINTH1*CFE
29343       CZ11=SINTH1*SFE
29344       CX22=-COSTH2
29345       CY22=-SINTH2*CFE
29346       CZ22=-SINTH2*SFE
29347
29348       SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29349       COD(1)=CX11*COD(3)+CZ11*SID3
29350       IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29351         WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29352      &    COD(1),COF(3),SID3,CX11,CZ11
29353         CALL PHO_PREVNT(-1)
29354       ENDIF
29355
29356       SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29357       COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29358       SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29359       COD(2)=CX22*COD(3)+CZ22*SID3
29360       SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29361       COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29362       SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29363
29364       END
29365
29366 *$ CREATE PHO_DFMASS.FOR
29367 *COPY PHO_DFMASS
29368 CDECK  ID>, PHO_DFMASS
29369       DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29370 C**********************************************************************
29371 C
29372 C     sampling of Mx diffractive mass distribution within
29373 C              limits XMIN, XMAX
29374 C
29375 C     input:    XMIN,XMAX     mass limitations (GeV)
29376 C               PREF2         original particle mass/ reference mass
29377 C                             (squared, GeV**2)
29378 C               PVIRT2        particle virtuality
29379 C               IMODE         M**2 mass distribution
29380 C                             1      1/(M**2+Q**2)
29381 C                             2      1/(M**2+Q**2)**alpha
29382 C                            -1      1/(M**2-Mref**2+Q**2)
29383 C                            -2      1/(M**2-Mref**2+Q**2)**alpha
29384 C
29385 C     output:   diffractive mass (GeV)
29386 C
29387 C**********************************************************************
29388       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29389       SAVE
29390
29391       PARAMETER(EPS  = 1.D-10)
29392
29393 C  input/output channels
29394       INTEGER LI,LO
29395       COMMON /POINOU/ LI,LO
29396 C  event debugging information
29397       INTEGER NMAXD
29398       PARAMETER (NMAXD=100)
29399       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29400      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29401       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29402      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29403 C  model switches and parameters
29404       CHARACTER*8 MDLNA
29405       INTEGER ISWMDL,IPAMDL
29406       DOUBLE PRECISION PARMDL
29407       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29408 C  some constants
29409       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29410       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29411      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29412
29413       IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29414         WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29415      &    'invalid mass limits',XMIN,XMAX,PREF2
29416         CALL PHO_PREVNT(-1)
29417         PHO_DFMASS = 0.135D0
29418         RETURN
29419       ENDIF
29420
29421       IF(IMODE.GT.0) THEN
29422         PM2 = -PVIRT2
29423       ELSE
29424         PM2 = PREF2 - PVIRT2
29425       ENDIF
29426
29427 C  critical pomeron
29428       IF(ABS(IMODE).EQ.1) THEN
29429         XMIN2 = LOG(XMIN**2-PM2)
29430         XMAX2 = LOG(XMAX**2-PM2)
29431         XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29432         XMA2 = EXP(XI)+PM2
29433
29434 C  supercritical pomeron
29435       ELSE IF(ABS(IMODE).EQ.2) THEN
29436         DDELTA = 1.D0-PARMDL(48)
29437         XMIN2 = (XMIN**2-PM2)**DDELTA
29438         XMAX2 = (XMAX**2-PM2)**DDELTA
29439         XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29440         XMA2 = XI**(1.D0/DDELTA)+PM2
29441       ELSE
29442         WRITE(LO,'(/,1X,A,I3)')
29443      &    'PHO_DFMASS:ERROR: unsupported mode',IMODE
29444         CALL PHO_ABORT
29445       ENDIF
29446
29447       PHO_DFMASS = SQRT(XMA2)
29448 C  debug output
29449       IF(IDEB(43).GE.15) THEN
29450         WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29451      &    XMIN,XMAX,PREF2,SQRT(XMA2)
29452       ENDIF
29453
29454       END
29455
29456 *$ CREATE PHO_DIFSLP.FOR
29457 *COPY PHO_DIFSLP
29458 CDECK  ID>, PHO_DIFSLP
29459       SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29460      &                  TT,SLWGHT,IREJ)
29461 C**********************************************************************
29462 C
29463 C     sampling of T  (Mandelstam variable) distribution within
29464 C     certain limits TMIN, TMAX
29465 C
29466 C     input:    IDF1,2     type of diffractive vertex
29467 C                           0   elastic/quasi-elastic scattering
29468 C                           1   diffraction dissociation
29469 C               IVEC1,2    vector meson IDs in case of quasi-elastic
29470 C                          scattering, otherwise 0
29471 C               XM1        mass of diffractive system 1 (GeV)
29472 C               XM2        mass of diffractive system 2 (GeV)
29473 C               XMX        max. mass of diffractive system (GeV)
29474 C
29475 C     output:   TT         squared momentum transfer ( < 0, GeV**2)
29476 C               SLWGHT     weight to allow for mass-dependent slope
29477 C               IREJ       0  successful sampling
29478 C                          1  masses too big for given T range
29479 C
29480 C**********************************************************************
29481       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29482       SAVE
29483
29484       PARAMETER(EPS  = 1.D-10)
29485
29486 C  input/output channels
29487       INTEGER LI,LO
29488       COMMON /POINOU/ LI,LO
29489 C  event debugging information
29490       INTEGER NMAXD
29491       PARAMETER (NMAXD=100)
29492       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29493      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29494       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29495      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29496 C  model switches and parameters
29497       CHARACTER*8 MDLNA
29498       INTEGER ISWMDL,IPAMDL
29499       DOUBLE PRECISION PARMDL
29500       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29501 C  internal rejection counters
29502       INTEGER NMXJ
29503       PARAMETER (NMXJ=60)
29504       CHARACTER*10 REJTIT
29505       INTEGER IFAIL
29506       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29507 C  c.m. kinematics of diffraction
29508       INTEGER NPOSD
29509       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29510      &                 SIDD,CODD,SIFD,COFD,PDCMS
29511       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29512      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29513 C  cross sections
29514       INTEGER IPFIL,IFAFIL,IFBFIL
29515       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29516      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29517      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29518      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29519      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29520       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29521      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29522      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29523      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29524      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29525      &                IPFIL,IFAFIL,IFBFIL
29526 C  Reggeon phenomenology parameters
29527       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29528      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29529       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29530      &                ALREG,ALREGP,GR(2),B0REG(2),
29531      &                GPPP,GPPR,B0PPP,B0PPR,
29532      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29533 C  parameters of 2x2 channel model
29534       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29535       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29536 C  parameters of the "simple" Vector Dominance Model
29537       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29538       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29539 C  some constants
29540       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29541       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29542      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29543
29544       IREJ = 0
29545       XM12 = XM1**2
29546       XM22 = XM2**2
29547       SS = ECMD**2
29548 C
29549 C  range of momentum transfer t
29550       TMIN = -PARMDL(68)
29551       TMAX = -PARMDL(69)
29552 C  determine min. abs(t) necessary to produce masses
29553       PCM2 = PCMD**2
29554       PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29555       IF(PCMP2.LE.0.D0) THEN
29556         IREJ = 1
29557         TT = 0.D0
29558         RETURN
29559       ENDIF
29560       TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29561      &        -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29562 C
29563       IF(TMINP.LT.TMAX) THEN
29564         IF(IDEB(44).GE.3) THEN
29565           WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29566      &      'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29567      &      XM1,XM2,TMIN,TMAX,TMINP
29568         ENDIF
29569         IFAIL(32) = IFAIL(32)+1
29570         IREJ = 1
29571         TT = 0.D0
29572         RETURN
29573       ENDIF
29574       TMINA = MIN(TMIN,TMINP)
29575 C
29576 C  calculation of slope (mass-dependent parametrization)
29577       IF(IDF1+IDF2.GT.0) THEN
29578 C  diffraction dissociation
29579         XMP12 = XM1**2+PVIRTD(1)
29580         XMP22 = XM2**2+PVIRTD(2)
29581         XMX1 = SQRT(XMP12)
29582         XMX2 = SQRT(XMP22)
29583         CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29584         FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29585         SLOPE = DBLE(IDF1+IDF2)*B0PPP
29586      &    +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29587      &    /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29588         SLOPE = MAX(SLOPE,1.D0)
29589 C
29590         XMA1 = XMX
29591         XMA2 = XMX
29592         IF(IDF1.EQ.0) THEN
29593           XMA1 = XM1
29594         ELSE IF(IDF1.EQ.0) THEN
29595           XMA2 = XM2
29596         ENDIF
29597         XMP12 = XMA1**2+PVIRTD(1)
29598         XMP22 = XMA2**2+PVIRTD(2)
29599         XMX1 = SQRT(XMP12)
29600         XMX2 = SQRT(XMP22)
29601         CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29602         SLMIN = DBLE(IDF1+IDF2)*B0PPP
29603      &    +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29604      &    /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29605         SLMIN = MAX(SLMIN,1.D0)
29606       ELSE
29607 C  elastic/quasi-elastic scattering
29608         IF(ISWMDL(13).EQ.0) THEN
29609 C  external slope values
29610           WRITE(LO,*) 'PHO_DIFSLP:ERROR: this option is not installed !'
29611           CALL PHO_ABORT
29612         ELSE IF(ISWMDL(13).EQ.1) THEN
29613 C  model slopes
29614           IF(IVEC1*IVEC2.EQ.0) THEN
29615             SLOPE = SLOEL
29616           ELSE
29617             SLOPE = SLOVM(IVEC1,IVEC2)
29618           ENDIF
29619           SLMIN = SLOPE
29620         ELSE
29621           WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29622      &      ISWMDL(13)
29623           CALL PHO_ABORT
29624         ENDIF
29625       ENDIF
29626 C
29627 C  determine max. abs(t) to avoid underflows
29628       TMAXP = -25.D0/SLOPE
29629       TMAXA = MAX(TMAX,TMAXP)
29630 C
29631       IF(TMINA.LT.TMAXA) THEN
29632         IF(IDEB(44).GE.3) THEN
29633           WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29634      &      'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29635      &      XM1,XM2,TMINA,TMAXA,SLOPE
29636         ENDIF
29637         IFAIL(32) = IFAIL(32)+1
29638         IREJ = 1
29639         TT = 0.D0
29640         RETURN
29641       ENDIF
29642 C
29643 C  sampling from corrected range of T
29644       TMINE = EXP(SLMIN*TMINA)
29645       TMAXE = EXP(SLMIN*TMAXA)
29646       XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29647       TT = LOG(XI)/SLMIN
29648       SLWGHT = EXP((SLOPE-SLMIN)*TT)
29649 C
29650 C  debug output
29651       IF(IDEB(44).GE.15) THEN
29652         WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29653      &    'PHO_DIFSLP: sampled momentum transfer:',TT,
29654      &    'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29655      &    'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29656       ENDIF
29657       END
29658
29659 *$ CREATE PHO_DIFKIN.FOR
29660 *COPY PHO_DIFKIN
29661 CDECK  ID>, PHO_DIFKIN
29662       SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29663 C**********************************************************************
29664 C
29665 C     calculation of diffractive kinematics
29666 C
29667 C     input:    XMP1         mass of outgoing particle system 1 (GeV)
29668 C               XMP2         mass of outgoing particle system 2 (GeV)
29669 C               TT           momentum transfer    (GeV**2, negative)
29670 C
29671 C     output:   PMOM1(5)     four momentum of outgoing system 1
29672 C               PMOM2(5)     four momentum of outgoing system 2
29673 C               IREJ         0    kinematics consistent
29674 C                            1    kinematics inconsistent
29675 C
29676 C**********************************************************************
29677       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29678       SAVE
29679
29680       PARAMETER(EPS  = 1.D-10,
29681      &          DEPS = 0.001)
29682
29683 C  input/output channels
29684       INTEGER LI,LO
29685       COMMON /POINOU/ LI,LO
29686 C  event debugging information
29687       INTEGER NMAXD
29688       PARAMETER (NMAXD=100)
29689       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29690      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29691       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29692      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29693 C  c.m. kinematics of diffraction
29694       INTEGER NPOSD
29695       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29696      &                 SIDD,CODD,SIFD,COFD,PDCMS
29697       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29698      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29699 C  some constants
29700       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29701       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29702      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29703
29704       DOUBLE PRECISION PMOM1,PMOM2
29705       DIMENSION PMOM1(5),PMOM2(5)
29706
29707 C  debug output
29708       IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29709      &    'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29710      &    ECMD,PCMD,XMP1,XMP2,TT
29711
29712 C  general kinematic constraints
29713       IREJ = 1
29714       IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29715
29716 C  new squared cms momentum
29717       XMP12 = XMP1**2
29718       XMP22 = XMP2**2
29719       SS = ECMD**2
29720       PCM2 = PCMD**2
29721       PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29722
29723 C  new longitudinal/transverse momentum
29724       E1I = SQRT(PCM2+PMASSD(1)**2)
29725       E1F = SQRT(PCMP2+XMP12)
29726       E2F = SQRT(PCMP2+XMP22)
29727       PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29728       PTRAN = PCMP2-PLONG**2
29729
29730 C  check consistency of kinematics
29731       IF(PTRAN.LT.0.D0) THEN
29732         IF(IDEB(49).GE.1) THEN
29733           WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29734      &      'inconsistent kinematics in event call: ',KEVENT
29735           WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
29736      &      'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
29737      &      XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
29738         ENDIF
29739         IREJ = 1
29740         RETURN
29741       ELSE
29742         PTRAN = SQRT(PTRAN)
29743       ENDIF
29744       XI = PI2*DT_RNDM(PTRAN)
29745
29746 C  outgoing momenta in cm. system
29747       PMOM1(4) = E1F
29748       PMOM1(1) = PTRAN*COS(XI)
29749       PMOM1(2) = PTRAN*SIN(XI)
29750       PMOM1(3) = PLONG
29751       PMOM1(5) = XMP1
29752
29753       PMOM2(4) = E2F
29754       PMOM2(1) = -PMOM1(1)
29755       PMOM2(2) = -PMOM1(2)
29756       PMOM2(3) = -PLONG
29757       PMOM2(5) = XMP2
29758       IREJ = 0
29759
29760 C  debug output / precision check
29761       IF(IDEB(49).GE.0) THEN
29762 C  check kinematics
29763         XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
29764      &        -PMOM1(1)**2-PMOM1(2)**2
29765         XM1 = SIGN(SQRT(ABS(XM1)),XM1)
29766         XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
29767      &        -PMOM2(1)**2-PMOM2(2)**2
29768         XM2 = SIGN(SQRT(ABS(XM2)),XM2)
29769         IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
29770           WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
29771      &      'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
29772      &      XMP1,XM1,XMP2,XM2
29773           CALL PHO_PREVNT(-1)
29774         ENDIF
29775 C  output
29776         IF(IDEB(49).GT.10) THEN
29777           WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
29778      &      'PHO_DIFKIN: P1',PMOM1,'                 P2',PMOM2
29779         ENDIF
29780       ENDIF
29781
29782       END
29783
29784 *$ CREATE PHO_VECRES.FOR
29785 *COPY PHO_VECRES
29786 CDECK  ID>, PHO_VECRES
29787       SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
29788 C**********************************************************************
29789 C
29790 C     sampling of vector meson resonance in diffractive processes
29791 C     (nothing done for hadrons)
29792 C
29793 C     input:   /POSVDM/     VDMFAC factors
29794 C
29795 C     output:  IVEC         0   incoming hadron
29796 C                           1   rho 0
29797 C                           2   omega
29798 C                           3   phi
29799 C                           4   pi+/pi- background
29800 C              RMASS        mass of vector meson (GeV)
29801 C              IDPDG        particle ID according to PDG
29802 C              IDBAM        particle ID according to CPC
29803 C
29804 C**********************************************************************
29805       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29806       SAVE
29807
29808       PARAMETER(EPS  = 1.D-10)
29809
29810 C  input/output channels
29811       INTEGER LI,LO
29812       COMMON /POINOU/ LI,LO
29813 C  event debugging information
29814       INTEGER NMAXD
29815       PARAMETER (NMAXD=100)
29816       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29817      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29818       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29819      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29820 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
29821       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
29822       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
29823       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
29824      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
29825 C  parameters of the "simple" Vector Dominance Model
29826       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29827       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29828 C  some constants
29829       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29830       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29831      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29832
29833 C  particle code translation
29834       DIMENSION ITRANS(4)
29835 C                  rho0,omega,phi,pi+/pi-
29836       DATA ITRANS /113, 223, 333, 92 /
29837
29838       IDPDO = IDPDG
29839 C
29840 C  vector meson production
29841       IF(IDPDG.EQ.22) THEN
29842         XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
29843         SUM = 0.D0
29844         DO 55 K=1,4
29845           SUM = SUM + VMFA(K)
29846           IF(XI.LE.SUM) GOTO 65
29847  55     CONTINUE
29848  65     CONTINUE
29849 C
29850         IDPDG = ITRANS(K)
29851         IDBAM = ipho_pdg2id(IDPDG)
29852         IVEC  = K
29853 C  sample mass of vector meson
29854         CALL PHO_SAMASS(IDPDG,RMASS)
29855
29856 C  hadronic resonance of multi-pomeron coupling
29857       ELSE IF(IDPDG.EQ.990) THEN
29858         K = 4
29859         IDPDG = 91
29860         IDBAM = ipho_pdg2id(IDPDG)
29861         IVEC  = 4
29862 C  sample mass of two-pion system
29863         CALL PHO_SAMASS(IDPDG,RMASS)
29864
29865 C  hadron remnants in inucleus interactions
29866       ELSE IF(IDPDG.EQ.81) THEN
29867         IF(IHFLD(1,1).EQ.0) THEN
29868           CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
29869           CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29870         ELSE
29871           CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
29872         ENDIF
29873         RMAS1 = PHO_PMASS(IDBA1,0)
29874         RMAS2 = PHO_PMASS(IDBA2,0)
29875         IF((IDBA2.NE.0).AND.
29876      &    (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29877           IDBAM = IDBA2
29878           RMASS = RMAS2
29879         ELSE
29880           IDBAM = IDBA1
29881           RMASS = RMAS1
29882         ENDIF
29883         IDPDG = IPHO_ID2PDG(IDBAM)
29884         IVEC = 0
29885       ELSE IF(IDPDG.EQ.82) THEN
29886         IF(IHFLD(2,1).EQ.0) THEN
29887           CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
29888           CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29889         ELSE
29890           CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
29891         ENDIF
29892         RMAS1 = PHO_PMASS(IDBA1,0)
29893         RMAS2 = PHO_PMASS(IDBA2,0)
29894         IF((IDBA2.NE.0).AND.
29895      &    (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29896           IDBAM = IDBA2
29897           RMASS = RMAS2
29898         ELSE
29899           IDBAM = IDBA1
29900           RMASS = RMAS1
29901         ENDIF
29902         IDPDG = IPHO_ID2PDG(IDBAM)
29903         IVEC = 0
29904       ENDIF
29905 C  debug output
29906       IF(IDEB(47).GE.5) THEN
29907         WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
29908      &    'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
29909      &    IDPDO,IDPDG,IDBAM,RMASS
29910       ENDIF
29911
29912       END
29913
29914 *$ CREATE PHO_DIFRES.FOR
29915 *COPY PHO_DIFRES
29916 CDECK  ID>, PHO_DIFRES
29917       SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
29918      &                  IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
29919 C**********************************************************************
29920 C
29921 C     list of resonance states for low mass resonances
29922 C
29923 C     input:   IDMOTH       PDG ID of mother particle
29924 C              IVAL1,2      quarks (photon only)
29925 C
29926 C     output:  IDPDG        list of PDG IDs for possible resonances
29927 C              IDBAM        list of corresponding CPC IDs
29928 C              RMASS        mass
29929 C              RGAMS        decay width
29930 C              RMASS        additional weight factor
29931 C              LISTL        entries in current list
29932 C
29933 C**********************************************************************
29934       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29935       SAVE
29936
29937       DIMENSION  IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
29938
29939       PARAMETER (EPS    =  1.D-10,
29940      &           DEPS   =  1.D-15)
29941
29942 C  input/output channels
29943       INTEGER LI,LO
29944       COMMON /POINOU/ LI,LO
29945 C  event debugging information
29946       INTEGER NMAXD
29947       PARAMETER (NMAXD=100)
29948       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29949      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29950       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29951      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29952 C  particle ID translation table
29953       integer         ID_pdg_list,ID_list,ID_pdg_max
29954       character*12    name_list
29955       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
29956      &                ID_pdg_max
29957 C  general particle data
29958       double precision xm_list,tau_list,gam_list,
29959      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29960      &  xm_bb82_list,xm_bb102_list
29961       integer          ich3_list,iba3_list,iq_list,
29962      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
29963       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29964      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
29965      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29966      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29967      &  ich3_list(300),iba3_list(300),iq_list(3,300),
29968      &  id_psm_list(6,6),id_vem_list(6,6),
29969      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
29970
29971       DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
29972       DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
29973      &            12212, 42212, -12212, -42212,
29974      &            8*0 /
29975       DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
29976      &            1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
29977      &            8*1.D0 /
29978
29979       DATA init /0/
29980
29981 C  initialize table
29982       if(init.eq.0) then
29983         do i=1,20
29984           if(IRPDG(i).ne.0) then
29985             IRBAM(i) = ipho_pdg2id(IRPDG(i))
29986           endif
29987         enddo
29988         init = 1
29989       endif
29990
29991 C  copy table with particles and isospin weights
29992       LISTL = 0
29993       IF(IDMOTH.EQ.22) THEN
29994         I1 = 4
29995         I2 = 8
29996       ELSE IF(IDMOTH.EQ.2212) THEN
29997         I1 = 9
29998         I2 = 10
29999       ELSE IF(IDMOTH.EQ.-2212) THEN
30000         I1 = 11
30001         I2 = 12
30002       ELSE
30003         RETURN
30004       ENDIF
30005
30006       DO 100 I=I1,I2
30007         LISTL = LISTL+1
30008         IDBAM(LISTL) = IRBAM(I)
30009         IDPDG(LISTL) = IRPDG(I)
30010         RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
30011         RGAM(LISTL)  = gam_list(iabs(IDBAM(LISTL)))
30012         RWG(LISTL)   = RWGHT(I)
30013  100  CONTINUE
30014
30015 C  debug output
30016       IF(IDEB(85).GE.20) THEN
30017         WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
30018      &    IVAL1,IVAL2
30019         DO 200 I=1,LISTL
30020           WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
30021  200    CONTINUE
30022       ENDIF
30023
30024       END
30025
30026 *$ CREATE PHO_MASSAD.FOR
30027 *COPY PHO_MASSAD
30028 CDECK  ID>, PHO_MASSAD
30029       SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30030      &                     PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30031 C***********************************************************************
30032 C
30033 C    fine-correction of low mass strings to mass of corresponding
30034 C    resonance or two particle threshold
30035 C
30036 C    input:     IFLMO         PDG ID of mother particle
30037 C               IFL1,2        requested parton flavours
30038 C                             (not used at the moment)
30039 C               PMASS         reference mass (mass of mother particle)
30040 C               XMCON         conjecture of mass
30041 C
30042 C    output:    XMOUT         output mass (adjusted input mass)
30043 C                             moved ot nearest mass possible
30044 C               IDPDG         PDG resonance ID
30045 C               IDcpc         CPC resonance ID
30046 C
30047 C**********************************************************************
30048       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30049       SAVE
30050
30051       PARAMETER ( DEPS   =  1.D-8 )
30052
30053 C  input/output channels
30054       INTEGER LI,LO
30055       COMMON /POINOU/ LI,LO
30056 C  event debugging information
30057       INTEGER NMAXD
30058       PARAMETER (NMAXD=100)
30059       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30060      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30061       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30062      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30063 C  model switches and parameters
30064       CHARACTER*8 MDLNA
30065       INTEGER ISWMDL,IPAMDL
30066       DOUBLE PRECISION PARMDL
30067       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30068 C  general particle data
30069       double precision xm_list,tau_list,gam_list,
30070      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30071      &  xm_bb82_list,xm_bb102_list
30072       integer          ich3_list,iba3_list,iq_list,
30073      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
30074       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30075      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
30076      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30077      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30078      &  ich3_list(300),iba3_list(300),iq_list(3,300),
30079      &  id_psm_list(6,6),id_vem_list(6,6),
30080      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
30081 C  particle decay data
30082       double precision wg_sec_list
30083       integer          idec_list,isec_list
30084       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30085      &  isec_list(3,500)
30086
30087       DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30088
30089       XMINP = XMCON
30090       IDPDG = 0
30091       IDcpc = 0
30092       XMOUT = XMINP
30093
30094 C  resonance treatment activated?
30095       IF(ISWMDL(23).EQ.0) RETURN
30096
30097       CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30098       IF(LISTL.LT.1) THEN
30099         IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30100      &    'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30101      &    IFLMO,IFL1,IFL2
30102         GOTO 50
30103       ENDIF
30104 C  mass small?
30105       PMASSL = (PMASS+0.15D0)**2
30106       XMINP2 = XMINP**2
30107 C  determine resonance probability
30108       DM2 = 1.1D0
30109       RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30110       IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30111 C  sample new resonance
30112         XWGSUM = 0.D0
30113         DO 100 I=1,LISTL
30114           XWG(I) = RWG(I)/RMA(I)**2
30115           XWGSUM = XWGSUM+XWG(I)
30116  100    CONTINUE
30117
30118         ITER = 0
30119  150    CONTINUE
30120         ITER = ITER+1
30121         IF(ITER.GE.5) THEN
30122           IDcpc = 0
30123           IDPDG = 0
30124           XMOUT = XMINP
30125           GOTO 50
30126         ENDIF
30127
30128         I = 0
30129         XI = XWGSUM*DT_RNDM(XMOUT)
30130  200    CONTINUE
30131           I = I+1
30132           XWGSUM = XWGSUM-XWG(I)
30133         IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30134         IDPDG = IRPDG(I)
30135         IDcpc = IRBAM(I)
30136         GARES = RGA(I)
30137         XMRES = RMA(I)
30138         XMRES2 = XMRES**2
30139 C  sample new mass (from Breit-Wigner cross section)
30140         ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30141         AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30142         XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30143         XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30144         XMOUT = SQRT(XMOUT)
30145
30146 C  check mass for decay
30147         AMDCY = 2.D0*XMRES
30148         ID = abs(IDcpc)
30149         DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30150           AMSUM = 0.D0
30151           DO 275 I=1,3
30152             IF(isec_list(I,IK).NE.0)
30153      &        AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30154  275      CONTINUE
30155           AMDCY = MIN(AMDCY,AMSUM)
30156  250    CONTINUE
30157         IF(AMDCY.GE.XMOUT) GOTO 150
30158
30159 C  debug output
30160         IF(IDEB(7).GE.10)
30161      &    WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30162      &    'PHO_MASSAD: ',
30163      &    'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30164      &    IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30165         RETURN
30166       ENDIF
30167
30168  50   CONTINUE
30169 C  debug output
30170       IF(IDEB(7).GE.15)
30171      &  WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30172      &    'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30173      &    IFLMO,IFL1,IFL2,XMCON,XMOUT
30174
30175       END
30176
30177 *$ CREATE PHO_PDF.FOR
30178 *COPY PHO_PDF
30179 CDECK  ID>, PHO_PDF
30180       SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30181 C***************************************************************
30182 C
30183 C     call different PDF sets for different particle types
30184 C
30185 C     input:      NPAR     1     IGRP(1),ISET(1)
30186 C                          2     IGRP(2),ISET(2)
30187 C                 X        momentum fraction
30188 C                 SCALE2   squared scale (GeV**2)
30189 C                 P2VIR    particle virtuality (positive, GeV**2)
30190 C
30191 C     output      PD(-6:6) field containing the x*PDF fractions
30192 C
30193 C***************************************************************
30194       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30195       SAVE
30196
30197       DIMENSION PD(-6:6)
30198
30199 C  input/output channels
30200       INTEGER LI,LO
30201       COMMON /POINOU/ LI,LO
30202 C  currently activated parton density parametrizations
30203       CHARACTER*8 PDFNAM
30204       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30205       DOUBLE PRECISION PDFLAM,PDFQ2M
30206       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30207      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30208 C  event debugging information
30209       INTEGER NMAXD
30210       PARAMETER (NMAXD=100)
30211       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30212      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30213       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30214      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30215 C  model switches and parameters
30216       CHARACTER*8 MDLNA
30217       INTEGER ISWMDL,IPAMDL
30218       DOUBLE PRECISION PARMDL
30219       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30220
30221       DIMENSION PARAM(20),VALUE(20)
30222       CHARACTER*20 PARAM
30223
30224       REAL XR,P2R,Q2R,F2GM,XPDFGM
30225       DIMENSION XPDFGM(-6:6)
30226
30227 C  check of kinematic boundaries
30228       XI = X
30229       IF(X.GT.1.D0) THEN
30230         IF(IDEB(37).GE.0) THEN
30231           WRITE(LO,'(/,1X,A,E15.8/)')
30232      &      'PHO_PDF: x>1 (corrected to x=1)',X
30233           CALL PHO_PREVNT(-1)
30234         ENDIF
30235         XI = 0.99999999999D0
30236       ELSE IF(X.LE.0.D0) THEN
30237         IF(IDEB(37).GE.0) THEN
30238           WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30239           CALL PHO_PREVNT(-1)
30240         ENDIF
30241         XI = 0.0001D0
30242       ENDIF
30243
30244       DO 100 I=-6,6
30245         PD(I) = 0.D0
30246  100  CONTINUE
30247       IRET = 1
30248
30249       IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30250
30251 C  internal PDFs
30252
30253         IF(IEXT(NPAR).EQ.0) THEN
30254           IF(ITYPE(NPAR).EQ.1) THEN
30255 C  proton PDFs
30256             IF(IGRP(NPAR).EQ.5) THEN
30257               IF(ISET(NPAR).EQ.3) THEN
30258                 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30259                 UV = UDV-DV
30260                 UDB = 2.D0*UDB
30261                 DEL = 0.D0
30262                 IRET = 0
30263               ELSE IF(ISET(NPAR).EQ.4) THEN
30264                 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30265                 UV = UDV-DV
30266                 UDB = 2.D0*UDB
30267                 DEL = 0.D0
30268                 IRET = 0
30269               ELSE IF(ISET(NPAR).EQ.5) THEN
30270                 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30271 C  heavy quarks from GRV92-HO
30272                 AMU2  = 0.3
30273                 ALAM2 = 0.248 * 0.248
30274                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30275                 SC  =  0.820
30276                 ALC =   0.98
30277                 BEC =   0.0
30278                 AKC = -0.625 - 0.523 * S
30279                 AGC =   0.0
30280                 BC  =  1.896 + 1.616 * S
30281                 DC  =   4.12 + 0.683 * S
30282                 EC  =   4.36 + 1.328 * S
30283                 ESC =  0.677 + 0.679 * S
30284                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30285                 SBO =  1.297
30286                 ALB =   0.99
30287                 BEB =   0.0
30288                 AKB =   0.0  - 0.193 * S
30289                 AGB =   0.0
30290                 BBO =   0.0
30291                 DB  =  3.447 + 0.927 * S
30292                 EB  =   4.68 + 1.259 * S
30293                 ESB =  1.892 + 2.199 * S
30294                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30295                 IRET = 0
30296               ELSE IF(ISET(NPAR).EQ.6) THEN
30297                 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30298 C  heavy quarks from GRV92-LO
30299                 AMU2  = 0.25
30300                 ALAM2 = 0.232D0**2
30301                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30302                 SC  =  0.888
30303                 ALC =   1.01
30304                 BEC =   0.37
30305                 AKC =   0.0
30306                 AGC =   0.0
30307                 BC  =   4.24 - 0.804 * S
30308                 DC  =   3.46 + 1.076 * S
30309                 EC  =   4.61 + 1.490 * S
30310                 ESC =  2.555 + 1.961 * S
30311                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30312                 SBO =  1.351
30313                 ALB =   1.00
30314                 BEB =   0.51
30315                 AKB =   0.0
30316                 AGB =   0.0
30317                 BBO =  1.848
30318                 DB  =  2.929 + 1.396 * S
30319                 EB  =   4.71 + 1.514 * S
30320                 ESB =   4.02 + 1.239 * S
30321                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30322                 IRET = 0
30323               ELSE IF(ISET(NPAR).EQ.7) THEN
30324                 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30325 C  heavy quarks from GRV92-HO
30326                 AMU2  = 0.3
30327                 ALAM2 = 0.248 * 0.248
30328                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30329                 SC  =  0.820
30330                 ALC =   0.98
30331                 BEC =   0.0
30332                 AKC = -0.625 - 0.523 * S
30333                 AGC =   0.0
30334                 BC  =  1.896 + 1.616 * S
30335                 DC  =   4.12 + 0.683 * S
30336                 EC  =   4.36 + 1.328 * S
30337                 ESC =  0.677 + 0.679 * S
30338                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30339                 SBO =  1.297
30340                 ALB =   0.99
30341                 BEB =   0.0
30342                 AKB =   0.0  - 0.193 * S
30343                 AGB =   0.0
30344                 BBO =   0.0
30345                 DB  =  3.447 + 0.927 * S
30346                 EB  =   4.68 + 1.259 * S
30347                 ESB =  1.892 + 2.199 * S
30348                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30349                 IRET = 0
30350               ELSE IF(ISET(NPAR).EQ.8) THEN
30351                 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30352                 DEL = DS-US
30353                 UDB = DS+US
30354 C  heavy quarks from GRV92-LO
30355                 AMU2  = 0.25
30356                 ALAM2 = 0.232D0**2
30357                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30358                 SC  =  0.888
30359                 ALC =   1.01
30360                 BEC =   0.37
30361                 AKC =   0.0
30362                 AGC =   0.0
30363                 BC  =   4.24 - 0.804 * S
30364                 DC  =   3.46 + 1.076 * S
30365                 EC  =   4.61 + 1.490 * S
30366                 ESC =  2.555 + 1.961 * S
30367                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30368                 SBO =  1.351
30369                 ALB =   1.00
30370                 BEB =   0.51
30371                 AKB =   0.0
30372                 AGB =   0.0
30373                 BBO =  1.848
30374                 DB  =  2.929 + 1.396 * S
30375                 EB  =   4.71 + 1.514 * S
30376                 ESB =   4.02 + 1.239 * S
30377                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30378                 IRET = 0
30379               ELSE IF(ISET(NPAR).EQ.9) THEN
30380 *               CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30381                 DEL = DS-US
30382                 UDB = DS+US
30383 C  heavy quarks from GRV92-LO
30384                 AMU2  = 0.25
30385                 ALAM2 = 0.232D0**2
30386                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30387                 SC  =  0.888
30388                 ALC =   1.01
30389                 BEC =   0.37
30390                 AKC =   0.0
30391                 AGC =   0.0
30392                 BC  =   4.24 - 0.804 * S
30393                 DC  =   3.46 + 1.076 * S
30394                 EC  =   4.61 + 1.490 * S
30395                 ESC =  2.555 + 1.961 * S
30396                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30397                 SBO =  1.351
30398                 ALB =   1.00
30399                 BEB =   0.51
30400                 AKB =   0.0
30401                 AGB =   0.0
30402                 BBO =  1.848
30403                 DB  =  2.929 + 1.396 * S
30404                 EB  =   4.71 + 1.514 * S
30405                 ESB =   4.02 + 1.239 * S
30406                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30407                 IRET = 0
30408               ENDIF
30409               PD(-5) = BB
30410               PD(-4) = CB
30411               PD(-3) = SB
30412               PD(-2) = 0.5D0*(UDB-DEL)
30413               PD(-1) = 0.5D0*(UDB+DEL)
30414               PD(0)  = GL
30415               PD(1)  = DV+PD(-1)
30416               PD(2)  = UV+PD(-2)
30417               PD(3)  = PD(-3)
30418               PD(4)  = PD(-4)
30419               PD(5)  = PD(-5)
30420             ENDIF
30421           ELSE IF(ITYPE(NPAR).EQ.2) THEN
30422 C  pion PDFs (default for pi+)
30423             IF(IGRP(NPAR).EQ.5) THEN
30424               IF(ISET(NPAR).EQ.1) THEN
30425                 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30426                 IRET = 0
30427               ELSE IF(ISET(NPAR).EQ.2) THEN
30428                 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30429                 IRET = 0
30430               ENDIF
30431               PD(-5) = BB
30432               PD(-4) = CB
30433               PD(-3) = QB
30434               PD(-2) = QB
30435               PD(-1) = QB+VA
30436               PD(0)  = GL
30437               PD(1)  = QB
30438               PD(2)  = VA+QB
30439               PD(3)  = QB
30440               PD(4)  = CB
30441               PD(5)  = BB
30442             ENDIF
30443           ELSE IF(ITYPE(NPAR).EQ.3) THEN
30444 C  photon PDFs
30445             IF(IGRP(NPAR).EQ.5) THEN
30446               IF(ISET(NPAR).EQ.1) THEN
30447                 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30448                 IRET = 0
30449               ELSE IF(ISET(NPAR).EQ.2) THEN
30450                 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30451                 IRET = 0
30452               ELSE IF(ISET(NPAR).EQ.3) THEN
30453                 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30454                 IRET = 0
30455               ENDIF
30456 C  reweight with Drees-Godbole factor
30457               WGX = 1.D0
30458               IF(P2VIR.GT.0.001D0) THEN
30459                 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30460      &               /LOG(SCALE2/PARMDL(144))
30461                 WGX = MAX(WGX,0.D0)
30462               ENDIF
30463               PD(-5) = BB*WGX/137.D0
30464               PD(-4) = CB*WGX/137.D0
30465               PD(-3) = SB*WGX/137.D0
30466               PD(-2) = UB*WGX/137.D0
30467               PD(-1) = DB*WGX/137.D0
30468               PD(0)  = GL*WGX*WGX/137.D0
30469               PD(1)  = PD(-1)
30470               PD(2)  = PD(-2)
30471               PD(3)  = PD(-3)
30472               PD(4)  = PD(-4)
30473               PD(5)  = PD(-5)
30474             ELSE IF(IGRP(NPAR).EQ.8) THEN
30475               IF(ISET(NPAR).EQ.1) THEN
30476                 CALL PHO_PHGAL (XI,SCALE2,PD)
30477                 IRET = 0
30478               ENDIF
30479             ENDIF
30480           ELSE IF(ITYPE(NPAR).EQ.20) THEN
30481 C  Pomeron PDFs
30482             MODE = IGRP(NPAR)
30483             IF(MODE.EQ.1) THEN
30484               PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30485               IRET = 0
30486             ELSE IF(MODE.EQ.2) THEN
30487               PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30488               IRET = 0
30489             ELSE IF(MODE.EQ.3) THEN
30490               PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30491               IRET = 0
30492             ELSE IF(MODE.EQ.4) THEN
30493               CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30494               DO 105 I=-4,4
30495                 PD(I) = PD(I)*PARMDL(78)
30496  105          CONTINUE
30497               IRET = 0
30498             ENDIF
30499           ENDIF
30500
30501 C  external PDFs
30502
30503         ELSE IF(IEXT(NPAR).EQ.2) THEN
30504 C  PDFLIB call: new PDF numbering
30505           IF(NPAR.NE.NPAOLD) THEN
30506             PARAM(1) = 'NPTYPE'
30507             PARAM(2) = 'NGROUP'
30508             PARAM(3) = 'NSET'
30509             PARAM(4) = ' '
30510             VALUE(1) = ITYPE(NPAR)
30511             VALUE(2) = ABS(IGRP(NPAR))
30512             VALUE(3) = ISET(NPAR)
30513             CALL PDFSET(PARAM,VALUE)
30514           ENDIF
30515           IF(ITYPE(NPAR).EQ.3) THEN
30516             IP2 = 0
30517             CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30518      &                   PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30519           ELSE
30520             SCALE = SQRT(SCALE2)
30521             CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30522      &                   PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30523           ENDIF
30524           DO 115 I=3,6
30525             PD(I) = PD(-I)
30526  115      CONTINUE
30527           IF(ITYPE(NPAR).EQ.1) THEN
30528 C  proton valence quarks
30529             PD(1) = PD(1)+PD(-1)
30530             PD(2) = PD(2)+PD(-2)
30531           ELSE IF(ITYPE(NPAR).EQ.2) THEN
30532 C  pi+ valences
30533             DVAL = PD(1)
30534             PD(1) = PD(-1)
30535             PD(-1) = DVAL+PD(1)
30536             PD(2) = PD(2)+PD(-2)
30537           ELSE IF(ITYPE(NPAR).EQ.3) THEN
30538 C  photon conventions
30539             PD(1) = PD(-1)
30540             PD(2) = PD(-2)
30541           ENDIF
30542           IRET = 0
30543
30544         ELSE IF(IEXT(NPAR).EQ.3) THEN
30545 C  PHOLIB call: version 2.0
30546           CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30547           IF(IRET.LT.0) THEN
30548             WRITE(LO,'(/1X,A,I2)')
30549      &        'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30550             CALL PHO_ABORT
30551           ENDIF
30552           IRET = 0
30553
30554 C  photon PDFs depending on photon virtuality
30555
30556         ELSE IF(IEXT(NPAR).EQ.4) THEN
30557           IF(IGRP(NPAR).EQ.1) THEN
30558 C  Schuler/Sjostrand PDF (interface to single precision)
30559             XR = XI
30560             Q2R = SCALE2
30561             P2R = P2VIR
30562             IP2 = 0
30563             CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30564             DO 120 I=-6,6
30565               PD(I) = DBLE(XPDFGM(I))
30566  120        CONTINUE
30567             IRET = 0
30568           ELSE IF(IGRP(NPAR).EQ.5) THEN
30569 C  Gluck/Reya/Stratmann
30570             IF(ISET(NPAR).EQ.4) THEN
30571               CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30572               CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30573               IRET = 0
30574               PD(-5) = 0.D0
30575               PD(-4) = CB
30576               PD(-3) = SB/137.D0
30577               PD(-2) = UB/137.D0
30578               PD(-1) = DB/137.D0
30579               PD(0)  = GL/137.D0
30580               PD(1)  = PD(-1)
30581               PD(1)  = PD(-1)
30582               PD(2)  = PD(-2)
30583               PD(3)  = PD(-3)
30584               PD(4)  = PD(-4)
30585               PD(5)  = PD(-5)
30586             ENDIF
30587           ENDIF
30588         ENDIF
30589
30590 C  check for errors
30591
30592         IF(IRET.NE.0) THEN
30593           WRITE(LO,'(/1X,A,/10X,5I6)')
30594      &      'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30595      &      NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30596           CALL PHO_ABORT
30597         ENDIF
30598 C  error in NPAR
30599       ELSE
30600         WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30601         CALL PHO_ABORT
30602       ENDIF
30603       NPAOLD = NPAR
30604
30605 C  valence quark treatment
30606
30607       IF(ITYPE(NPAR).EQ.2) THEN
30608 C  meson conventions
30609         IF(IPARID(NPAR).EQ.111) THEN
30610 C  pi0 valence quarks
30611           PD(-1) = (PD(1)+PD(-1))/2.D0
30612           PD(1)  = PD(-1)
30613           PD(-2) = (PD(2)+PD(-2))/2.D0
30614           PD(2)  = PD(-2)
30615         ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30616 C  K+/-
30617           VALS = PD(-1)-PD(1)
30618           PD(-1) = PD(1)
30619           PD(-3) = PD(-3)+VALS
30620         ELSE IF(    (IPARID(NPAR).EQ.311)
30621      &          .OR.(IPARID(NPAR).EQ.310)
30622      &          .OR.(IPARID(NPAR).EQ.130)) THEN
30623 C  neutral kaons
30624           VALS = PD(-1)-PD(1)
30625           VALU = PD(2)-PD(-2)
30626           PD(-1) = PD(1)
30627           PD(2) = PD(-2)
30628           PD(2)  = PD(2)+VALU/2.D0
30629           PD(-2) = PD(-2)+VALU/2.D0
30630           PD(3)  = PD(3)+VALS/2.D0
30631           PD(-3) = PD(-3)+VALS/2.D0
30632         ENDIF
30633       ELSE IF(ITYPE(NPAR).EQ.1) THEN
30634 C  nucleon conventions
30635         IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30636 C  neutron valence quarks
30637           DUM = PD(1)
30638           PD(1) = PD(2)
30639           PD(2) = DUM
30640         ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30641 C  (anti-)sigma+
30642           VALS = PD(1)-PD(-1)
30643           PD(1) = PD(-1)
30644           PD(3) = PD(3)+VALS
30645         ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30646 C  (anti-)sigma-
30647           VALS = PD(1)-PD(-1)
30648           VALD = PD(2)-PD(-2)
30649           PD(1) = PD(-1)
30650           PD(2) = PD(-2)
30651           PD(1) = PD(1)+VALD
30652           PD(3) = PD(3)+VALS
30653         ELSE IF(    (ABS(IPARID(NPAR)).EQ.3122)
30654      &          .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30655 C  (anti-)sigma0 and (anti-)lambda
30656           VALS = PD(1)-PD(-1)
30657           VALD = (PD(2)-PD(-2))/2.D0
30658           PD(1) = PD(-1)
30659           PD(2) = PD(-2)
30660           PD(1) = PD(1)+VALD
30661           PD(2) = PD(2)+VALD
30662           PD(3) = PD(3)+VALS
30663         ENDIF
30664       ENDIF
30665
30666 C  antiparticle
30667       IF(IPARID(NPAR).LT.0) THEN
30668         DO 190 I=1,4
30669           DUM=PD(I)
30670           PD(I)=PD(-I)
30671           PD(-I)=DUM
30672  190    CONTINUE
30673       ENDIF
30674
30675 C  optionally remove valence quarks
30676       IF(IPAVA(NPAR).EQ.0) THEN
30677         DO 200 I=1,4
30678           PD(I) = MIN(PD(-I),PD(I))
30679           PD(-I) = PD(I)
30680  200    CONTINUE
30681       ENDIF
30682
30683 C  debug information
30684       IF(IDEB(37).GE.30) WRITE(LO,
30685      &  '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30686      &  'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30687      &  NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30688      &  'PD(0)     ',PD(0),'PD(1..6)  ',(PD(I),I=1,6)
30689
30690       END
30691
30692 *$ CREATE PHO_QPMPDF.FOR
30693 *COPY PHO_QPMPDF
30694 CDECK  ID>, PHO_QPMPDF
30695       SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30696 C***************************************************************
30697 C
30698 C     contribution to photon PDF from box graph
30699 C     (Bethe-Heitler process)
30700 C
30701 C     input:      IQ       quark flavour
30702 C                 SCALE2   scale (GeV**2, positive)
30703 C                 PTREF    reference scale (GeV, positive)
30704 C                 X        parton momentum fraction
30705 C                 PVIRT    photon virtuality (GeV**2, positive)
30706 C                 FXP      x*f(x,Q**2), x times parton density
30707 C
30708 C***************************************************************
30709       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30710       SAVE
30711
30712 C  input/output channels
30713       INTEGER LI,LO
30714       COMMON /POINOU/ LI,LO
30715 C  event debugging information
30716       INTEGER NMAXD
30717       PARAMETER (NMAXD=100)
30718       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30719      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30720       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30721      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30722 C  internal rejection counters
30723       INTEGER NMXJ
30724       PARAMETER (NMXJ=60)
30725       CHARACTER*10 REJTIT
30726       INTEGER IFAIL
30727       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30728 C  some constants
30729       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30730       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30731      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30732
30733       DIMENSION QM(6)
30734       DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
30735
30736       FXP = 0.D0
30737       I = ABS(IQ)
30738 C
30739 *     QM2 = MAX(QM(I),PTREF)**2
30740 *     QM2 = MAX(QM2,PVIRT)
30741 *     BBE = (1.D0-X)*SCALE2
30742 *     IF(BBE.LE.0.D0) THEN
30743 *       IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30744 *    &    'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
30745 *    &    PVIRT,QM(I)
30746 *     ENDIF
30747 *     FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
30748 *    &  *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
30749 C  Bethe-Heitler process approximation for 2*x*p2/q2 << 1
30750       QM2 = MAX(QM(I),PTREF)**2
30751       W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
30752       IF(W2.GT.4.D0*QM2) THEN
30753         BE = SQRT(1.D0-4.D0*QM2/W2)
30754         BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30755         BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30756 *       FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
30757         FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
30758      &         +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
30759      &         -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
30760      &         +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
30761      &         -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
30762       ELSE
30763         IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30764      &    'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
30765      &    PVIRT,QM(I)
30766       ENDIF
30767 C  debug output
30768       IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
30769      &  'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
30770       END
30771
30772 *$ CREATE PHO_SETPDF.FOR
30773 *COPY PHO_SETPDF
30774 CDECK  ID>, PHO_SETPDF
30775       SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
30776 C***************************************************************
30777 C
30778 C     assigns  PDF numbers to particles
30779 C
30780 C     input:      IDPDG    PDG number of particle
30781 C                 ITYP     particle type
30782 C                 IPAR     PDF paramertization
30783 C                 ISET     number of set
30784 C                 IEXT     library number for PDF calculation
30785 C                 IPAVAL   (only output)
30786 C                          1 PDF with valence quarks
30787 C                          0 PDF without valence quarks
30788 C                 MODE     -1   add entry to table
30789 C                           1   read from table
30790 C                           2   output of table
30791 C
30792 C***************************************************************
30793       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30794       SAVE
30795
30796 C  input/output channels
30797       INTEGER LI,LO
30798       COMMON /POINOU/ LI,LO
30799 C  event debugging information
30800       INTEGER NMAXD
30801       PARAMETER (NMAXD=100)
30802       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30803      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30804       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30805      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30806 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
30807       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30808       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30809       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30810      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30811
30812       DIMENSION IPDFS(5,50)
30813       DATA IENTRY / 0 /
30814
30815       IF(MODE.EQ.1) THEN
30816         I = 1
30817         IF(IDPDG.EQ.81) THEN
30818           IDCMP = IDEQP(1)
30819           IPAVAL = IHFLS(1)
30820         ELSE IF(IDPDG.EQ.82) THEN
30821           IDCMP = IDEQP(2)
30822           IPAVAL = IHFLS(2)
30823         ELSE
30824           IDCMP = IDPDG
30825           IPAVAL = 1
30826         ENDIF
30827 200     CONTINUE
30828           IF(IDCMP.EQ.IPDFS(1,I)) THEN
30829             ITYP = IPDFS(2,I)
30830             IPAR = IPDFS(3,I)
30831             ISET = IPDFS(4,I)
30832             IEXT = IPDFS(5,I)
30833             IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
30834      &        'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
30835             RETURN
30836           ENDIF
30837           I = I+1
30838           IF(I.GT.IENTRY) THEN
30839             WRITE(LO,'(/1X,A,I7)')
30840      &        'PHO_SETPDF: no PDF assigned to ',IDCMP
30841             CALL PHO_ABORT
30842           ENDIF
30843         GOTO 200
30844       ELSE IF(MODE.EQ.-1) THEN
30845         DO 50 I=1,IENTRY
30846           IF(IDPDG.EQ.IPDFS(1,I)) THEN
30847             WRITE(LO,'(/1X,A,5I6)')
30848      &        'PHO_SETPDF: overwrite old particle PDF',
30849      &        IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30850             GOTO 100
30851           ENDIF
30852  50     CONTINUE
30853         I = IENTRY+1
30854         IF(I.GT.50) THEN
30855           WRITE(LO,'(/1X,A,/1x,6I6)')
30856      &      'PHO_SETPDF:ERROR: no space left in IPDFS:',
30857      &      I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30858           STOP
30859         ENDIF
30860         IENTRY = I
30861  100    CONTINUE
30862         IPDFS(1,I) = IDPDG
30863         IF(IDPDG.EQ.990) THEN
30864           ITYP1 = 20
30865         ELSE IF(IDPDG.EQ.22) THEN
30866           ITYP1 = 3
30867         ELSE IF(ABS(IDPDG).LT.1000) THEN
30868           ITYP1 = 2
30869         ELSE
30870           ITYP1 = 1
30871         ENDIF
30872         IPDFS(2,I) = ITYP1
30873         IPDFS(3,I) = IPAR
30874         IPDFS(4,I) = ISET
30875         IPDFS(5,I) = IEXT
30876       ELSE IF(MODE.EQ.-2) THEN
30877         WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
30878         DO 150 I=1,IENTRY
30879           WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,'  particle:',IPDFS(1,I),
30880      &      '   PDF-set  ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30881  150    CONTINUE
30882       ELSE
30883         WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
30884       ENDIF
30885       END
30886
30887 *$ CREATE PHO_GETPDF.FOR
30888 *COPY PHO_GETPDF
30889 CDECK  ID>, PHO_GETPDF
30890       SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
30891 C***************************************************************
30892 C
30893 C     get PDF information
30894 C
30895 C     input:      NPAR     1  first PDF in /POPPDF/
30896 C                          2  second PDF in /POPPDF/
30897 C
30898 C     output:     PDFNA    name of PDf parametrization
30899 C                 ALA      QCD LAMBDA (4 flavours, in GeV)
30900 C                 Q2MI     minimal Q2
30901 C                 Q2MA     maximal Q2
30902 C                 XMI      minimal X
30903 C                 XMA      maximal X
30904 C
30905 C***************************************************************
30906       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30907       SAVE
30908
30909       CHARACTER*8 PDFNA
30910
30911 C  input/output channels
30912       INTEGER LI,LO
30913       COMMON /POINOU/ LI,LO
30914
30915 C  PHOLIB 4.15 common
30916       COMMON /W50512/ QCDL4,QCDL5
30917       COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
30918
30919 C  PHOPDF version 2.0 common
30920       PARAMETER (MAXS=6,MAXP=10)
30921       CHARACTER*4 CHPAR
30922       COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
30923      & NSET(MAXP,2),NFL(MAXP)
30924       COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
30925
30926 C  currently activated parton density parametrizations
30927       CHARACTER*8 PDFNAM
30928       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30929       DOUBLE PRECISION PDFLAM,PDFQ2M
30930       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30931      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30932
30933       DIMENSION PARAM(20),VALUE(20)
30934       CHARACTER*20 PARAM
30935
30936       IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
30937         WRITE(LO,'(/1X,A,I6)')
30938      &    'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
30939         CALL PHO_ABORT
30940       ENDIF
30941       ALA = 0.D0
30942
30943       IF(IEXT(NPAR).EQ.0) THEN
30944
30945 C  internal parametrizations
30946
30947         IF(ITYPE(NPAR).EQ.1) THEN
30948 C  proton PDFs
30949           IF(IGRP(NPAR).EQ.5) THEN
30950             IF(ISET(NPAR).EQ.3) THEN
30951               ALA    = 0.2D0
30952               Q2MI   = 0.3D0
30953               PDFNA  = 'GRV92 HO'
30954             ELSE IF(ISET(NPAR).EQ.4) THEN
30955               ALA    = 0.2D0
30956               Q2MI   = 0.25D0
30957               PDFNA  = 'GRV92 LO'
30958             ELSE IF(ISET(NPAR).EQ.5) THEN
30959               ALA    = 0.2D0
30960               Q2MI   = 0.4D0
30961               PDFNA  = 'GRV94 HO'
30962             ELSE IF(ISET(NPAR).EQ.6) THEN
30963               ALA    = 0.2D0
30964               Q2MI   = 0.4D0
30965               PDFNA  = 'GRV94 LO'
30966             ELSE IF(ISET(NPAR).EQ.7) THEN
30967               ALA    = 0.2D0
30968               Q2MI   = 0.4D0
30969               PDFNA  = 'GRV94 DI'
30970             ELSE IF(ISET(NPAR).EQ.8) THEN
30971               ALA    = 0.175D0
30972               Q2MI   = 0.8D0
30973               PDFNA  = 'GRV98 LO'
30974             ELSE IF(ISET(NPAR).EQ.9) THEN
30975               ALA    = 0.175D0
30976               Q2MI   = 0.8D0
30977               PDFNA  = 'GRV98 SC'
30978             ENDIF
30979           ENDIF
30980         ELSE IF(ITYPE(NPAR).EQ.2) THEN
30981 C  pion PDFs
30982           IF(IGRP(NPAR).EQ.5) THEN
30983             IF(ISET(NPAR).EQ.1) THEN
30984               ALA    = 0.2D0
30985               Q2MI   = 0.3D0
30986               PDFNA  = 'GRV-P HO'
30987             ELSE IF(ISET(NPAR).EQ.2) THEN
30988               ALA    = 0.2D0
30989               Q2MI   = 0.25D0
30990               PDFNA  = 'GRV-P LO'
30991             ENDIF
30992           ENDIF
30993         ELSE IF(ITYPE(NPAR).EQ.3) THEN
30994 C  photon PDFs
30995           IF(IGRP(NPAR).EQ.5) THEN
30996             IF(ISET(NPAR).EQ.1) THEN
30997               ALA    = 0.2D0
30998               Q2MI   = 0.3D0
30999               PDFNA  = 'GRV-G LH'
31000             ELSE IF(ISET(NPAR).EQ.2) THEN
31001               ALA    = 0.2D0
31002               Q2MI   = 0.3D0
31003               PDFNA  = 'GRV-G HO'
31004             ELSE IF(ISET(NPAR).EQ.3) THEN
31005               ALA    = 0.2D0
31006               Q2MI   = 0.25D0
31007               PDFNA  = 'GRV-G LO'
31008             ENDIF
31009           ELSE IF(IGRP(NPAR).EQ.8) THEN
31010             IF(ISET(NPAR).EQ.1) THEN
31011               ALA    = 0.2D0
31012               Q2MI   = 4.D0
31013               PDFNA  = 'AGL-G LO'
31014             ENDIF
31015           ENDIF
31016         ELSE IF(ITYPE(NPAR).EQ.20) THEN
31017 C  pomeron PDFs
31018           IF(IGRP(NPAR).EQ.4) THEN
31019             CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
31020           ELSE
31021             ALA    = 0.3D0
31022             Q2MI   = 2.D0
31023             PDFNA  = 'POM-PDF1'
31024           ENDIF
31025         ENDIF
31026
31027 C  external parametrizations
31028
31029       ELSE IF(IEXT(NPAR).EQ.1) THEN
31030 C  PDFLIB call: old numbering
31031         PARAM(1) = 'MODE'
31032         PARAM(2) = ' '
31033         VALUE(1) = IGRP(NPAR)
31034         CALL PDFSET(PARAM,VALUE)
31035         Q2MI = Q2MIN
31036         Q2MA = Q2MAX
31037         XMI  = XMIN
31038         XMA  = XMAX
31039         ALA  = QCDL4
31040         PDFNA = 'PDFLIB1'
31041       ELSE IF(IEXT(NPAR).EQ.2) THEN
31042 C  PDFLIB call: new numbering
31043         PARAM(1) = 'NPTYPE'
31044         PARAM(2) = 'NGROUP'
31045         PARAM(3) = 'NSET'
31046         PARAM(4) = ' '
31047         VALUE(1) = ITYPE(NPAR)
31048         VALUE(2) = IGRP(NPAR)
31049         VALUE(3) = ISET(NPAR)
31050         CALL PDFSET(PARAM,VALUE)
31051         Q2MI = Q2MIN
31052         Q2MA = Q2MAX
31053         XMI  = XMIN
31054         XMA  = XMAX
31055         ALA  = QCDL4
31056         PDFNA = 'PDFLIB2'
31057       ELSE IF(IEXT(NPAR).EQ.3) THEN
31058 C  PHOLIB interface
31059         ALA  = ALM(IGRP(NPAR),ISET(NPAR))
31060         Q2MI = 2.D0
31061         PDFNA = CHPAR(IGRP(NPAR))
31062
31063 C  some special internal parametrizations
31064
31065       ELSE IF(IEXT(NPAR).EQ.4) THEN
31066 C  photon PDFs depending on virtualities
31067         IF(IGRP(NPAR).EQ.1) THEN
31068 C  Schuler/Sjostrand parametrization
31069           ALA = 0.2D0
31070           IF(ISET(NPAR).EQ.1) THEN
31071             Q2MI = 0.2D0
31072             PDFNA = 'SaS-1D  '
31073           ELSE IF(ISET(NPAR).EQ.2) THEN
31074             Q2MI = 0.2D0
31075             PDFNA = 'SaS-1M  '
31076           ELSE IF(ISET(NPAR).EQ.3) THEN
31077             Q2MI = 2.D0
31078             PDFNA = 'SaS-2D  '
31079           ELSE IF(ISET(NPAR).EQ.4) THEN
31080             Q2MI = 2.D0
31081             PDFNA = 'SaS-2M  '
31082           ENDIF
31083         ELSE IF(IGRP(NPAR).EQ.5) THEN
31084 C  Gluck/Reya/Stratmann parametrization
31085           IF(ISET(NPAR).EQ.4) THEN
31086             ALA = 0.2D0
31087             Q2MI = 0.6D0
31088             PDFNA = 'GRS-G LO'
31089           ENDIF
31090         ENDIF
31091       ELSE IF(IEXT(NPAR).EQ.5) THEN
31092 C  Schuler/Sjostrand anomalous only
31093         ALA   = 0.2D0
31094         Q2MI  = 0.2D0
31095         PDFNA = 'SaS anom'
31096       ENDIF
31097       IF(ALA.LT.0.01D0) THEN
31098         WRITE(LO,'(/1X,2A,/10X,5I6)')
31099      &    'PHO_GETPDF:ERROR: ',
31100      &    'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31101      &    NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31102         CALL PHO_ABORT
31103       ENDIF
31104
31105       END
31106
31107 *$ CREATE PHO_ACTPDF.FOR
31108 *COPY PHO_ACTPDF
31109 CDECK  ID>, PHO_ACTPDF
31110       SUBROUTINE PHO_ACTPDF(IDPDG,K)
31111 C***************************************************************
31112 C
31113 C     activate PDF for QCD calculations
31114 C
31115 C     input:      IDPDG    PDG particle number
31116 C                 K        1  first PDF in /POPPDF/
31117 C                          2  second PDF in /POPPDF/
31118 C                         -2  write current settings
31119 C
31120 C     output:     /POPPDF/
31121 C
31122 C***************************************************************
31123       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31124       SAVE
31125
31126 C  input/output channels
31127       INTEGER LI,LO
31128       COMMON /POINOU/ LI,LO
31129 C  event debugging information
31130       INTEGER NMAXD
31131       PARAMETER (NMAXD=100)
31132       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31133      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31134       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31135      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31136 C  currently activated parton density parametrizations
31137       CHARACTER*8 PDFNAM
31138       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31139       DOUBLE PRECISION PDFLAM,PDFQ2M
31140       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31141      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31142
31143       IF(K.GT.0) THEN
31144
31145 C  read PDF from table
31146         CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31147      &                 IPAVA(K),1)
31148         IPARID(K) = IDPDG
31149 C  get PDF parameters
31150         CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31151 C  initialize alpha_s calculation
31152         alam2 = PDFLAM(K)*PDFLAM(K)
31153         DUMMY = PHO_ALPHAS(alam2,-K)
31154
31155         IF(IDEB(2).GE.20) THEN
31156           WRITE(LO,'(1X,A)')
31157      &      'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31158           WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31159      &      PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31160      &      IEXT(K),IPARID(K)
31161         ENDIF
31162         NPAOLD = K
31163
31164       ELSE IF(K.EQ.-2) THEN
31165
31166 C  write table of current PDFs
31167         WRITE(LO,'(1X,A)')
31168      &    'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31169         WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31170      &    PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31171      &    IPARID(1)
31172         WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31173      &    PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31174      &    IPARID(2)
31175
31176       ELSE
31177
31178         WRITE(LO,'(/1X,A,2I4)')
31179      &    'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31180         CALL PHO_ABORT
31181
31182       ENDIF
31183
31184       END
31185
31186 *$ CREATE PHO_PDFTST.FOR
31187 *COPY PHO_PDFTST
31188 CDECK  ID>, PHO_PDFTST
31189       SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31190 C*********************************************************************
31191 C
31192 C     structure function test utility
31193 C
31194 C     input:    IDPDG    PDG ID of particle
31195 C               SCALE2   squared scale (GeV**2)
31196 C               P2MASS   particle virtuality (pos, GeV**2)
31197 C
31198 C     output:   tables of PDF, sum rule checking, table of F2
31199 C
31200 C*********************************************************************
31201       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31202       SAVE
31203
31204 C  input/output channels
31205       INTEGER LI,LO
31206       COMMON /POINOU/ LI,LO
31207 C  currently activated parton density parametrizations
31208       CHARACTER*8 PDFNAM
31209       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31210       DOUBLE PRECISION PDFLAM,PDFQ2M
31211       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31212      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31213 C  some constants
31214       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31215       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31216      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31217
31218       DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31219       CHARACTER*8 PDFNA
31220
31221       CALL PHO_ACTPDF(IDPDG,1)
31222       CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31223
31224       WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31225       WRITE(LO,'(A)') ' ======================================='
31226
31227       WRITE(LO,'(/,A,3I10)')
31228      &  ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31229       WRITE(LO,'(A,A)')     ' corresponds to ',PDFNA
31230       WRITE(LO,'(A,E12.3)') '  used squared scale (GeV**2):',SCALE2
31231       WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31232       WRITE(LO,'(/1X,A)') 'x times parton densities'
31233       WRITE(LO,'(1X,A)') '    X         PD(-4 - 4)'
31234       WRITE(LO,'(1X,A)')
31235      &   ' ============================================================'
31236
31237 C  logarithmic loop over x values
31238 C  upper bound
31239       XUPPER=0.9999D0
31240 C  lower bound
31241       XLOWER=1.D-4
31242 C  number of steps
31243       NSTEP=50
31244
31245       XFIRST=LOG(XLOWER)
31246       XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31247       DO 100 I=1,NSTEP
31248         X=EXP(XFIRST)
31249         XCONTR=X
31250         CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31251         IF(X.NE.XCONTR) THEN
31252           WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31253         ENDIF
31254         WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31255         XFIRST=XFIRST+XDELTA
31256  100  CONTINUE
31257
31258       IF(IDPDG.EQ.22) THEN
31259         WRITE(LO,'(/1X,A)')
31260      &   'comparison PDF to contribution due to box diagram'
31261         WRITE(LO,'(1X,A)') '    X   PD(1),PB(1), .... ,PD(4),PB(4)'
31262         WRITE(LO,'(1X,A)')
31263      &   ' ============================================================'
31264         XFIRST=LOG(XLOWER)
31265         XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31266         DO 110 I=1,NSTEP
31267           X=EXP(XFIRST)
31268           CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31269           DO 120 K=1,4
31270             CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31271  120      CONTINUE
31272           WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31273           XFIRST=XFIRST+XDELTA
31274  110    CONTINUE
31275       ENDIF
31276
31277 C  check momentum sum rule
31278
31279       WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31280       DO 199 I=-6,6
31281         PDSUM(I) = 0.D0
31282         PDAVE(I) = 0.D0
31283  199  CONTINUE
31284       ITER=5000
31285       DO 200 I=1,ITER
31286         XX=DBLE(I)/DBLE(ITER)
31287         IF(XX.EQ.1.D0) XX = 0.999999D0
31288         CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31289         DO 202 K=-6,6
31290           PDSUM(K) = PDSUM(K)+PD(K)/XX
31291           PDAVE(K) = PDAVE(K)+PD(K)
31292  202    CONTINUE
31293  200  CONTINUE
31294       WRITE(LO,'(1X,A)')
31295      &  'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31296       XSUM = 0.D0
31297       DO 204 I=-6,6
31298         PDSUM(I) = PDSUM(I)/DBLE(ITER)
31299         PDAVE(I) = PDAVE(I)/DBLE(ITER)
31300         XSUM = XSUM+PDAVE(I)
31301         WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31302  204  CONTINUE
31303       WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31304       DO 205 I=1,6
31305         WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31306  205  CONTINUE
31307       WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31308       WRITE(LO,'(A/)') ' ============================================='
31309
31310 C  table of F2
31311
31312       WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31313      &  'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31314      &  '-----------------------------------------------------'
31315       ITER=100
31316       DO 300 I=1,ITER
31317         XX=DBLE(I)/DBLE(ITER)
31318         IF(XX.EQ.1.D0) XX = 0.9999D0
31319         CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31320         F2 = 0.D0
31321         DO 302 K=-6,6
31322           IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31323  302    CONTINUE
31324         WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31325  300  CONTINUE
31326       WRITE(LO,'(A/)') ' ============================================='
31327       END
31328
31329 *$ CREATE PHO_REGPAR.FOR
31330 *COPY PHO_REGPAR
31331 CDECK  ID>, PHO_REGPAR
31332       SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31333      &                  IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31334 C**********************************************************************
31335 C
31336 C     registration of particle in /POEVT1/ and /POEVT2/
31337 C
31338 C     input:    ISTH             status code of particle
31339 C                                 -2     initial parton hard scattering
31340 C                                 -1     parton
31341 C                                  0     string
31342 C                                  1     visible particle (no color)
31343 C                                  2     decayed particle
31344 C               IDPDG            PDG particle ID code
31345 C               IDBAM            CPC particle ID code
31346 C               JM1,JM2          first and second mother index
31347 C               P1..P4           four momentum
31348 C               IPHIS1           extended history information
31349 C                                  IPHIS1<100: JM1 from particle 1
31350 C                                  IPHIS1>100: JM1 from particle 2
31351 C                                  1    valence quark
31352 C                                  2    valence diquark
31353 C                                  3    sea quark
31354 C                                  4    sea diquark
31355 C                                  (neg. for antipartons)
31356 C               IPHIS2           extended history information
31357 C                                  positive: JM2 from particle 1
31358 C                                  negative: JM2 from particle 2
31359 C                                  (see IPHIS1)
31360 C               IC1,IC2          color labels for partons
31361 C               IMODE            1  register given parton
31362 C                                0  reset /POEVT1/ and /POEVT2/
31363 C                                2  return data of entry IPOS
31364 C
31365 C               IPOS             position of particle in /POEVT1/
31366 C
31367 C**********************************************************************
31368       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31369       SAVE
31370
31371       PARAMETER (DEPS = 1.D-20)
31372
31373 C  input/output channels
31374       INTEGER LI,LO
31375       COMMON /POINOU/ LI,LO
31376 C  event debugging information
31377       INTEGER NMAXD
31378       PARAMETER (NMAXD=100)
31379       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31380      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31381       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31382      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31383 C  standard particle data interface
31384       INTEGER NMXHEP
31385       PARAMETER (NMXHEP=4000)
31386       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31387       DOUBLE PRECISION PHEP,VHEP
31388       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31389      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31390      &                VHEP(4,NMXHEP)
31391 C  extension to standard particle data interface (PHOJET specific)
31392       INTEGER IMPART,IPHIST,ICOLOR
31393       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31394
31395       IF(IMODE.EQ.1) THEN
31396         IF(IDEB(76).GE.26) THEN
31397           WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31398      &      'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31399      &      ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31400           WRITE(LO,'(1X,A,/2X,6I6)')
31401      &      'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31402      &      IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31403         ENDIF
31404         IF(NHEP.EQ.NMXHEP) THEN
31405           WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31406      &      'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31407           CALL PHO_ABORT
31408         ENDIF
31409         NHEP = NHEP+1
31410         IDBAMI = IDBAM
31411         IDPDGI = IDPDG
31412         IF(ABS(ISTH).LE.2) THEN
31413           IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31414             IDPDGI = ipho_id2pdg(IDBAM)
31415           ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31416             IDBAMI = ipho_pdg2id(IDPDG)
31417           ENDIF
31418         ENDIF
31419 C  standard data
31420         ISTHEP(NHEP) = ISTH
31421         IDHEP(NHEP)  = IDPDGI
31422         JMOHEP(1,NHEP) = JM1
31423         JMOHEP(2,NHEP) = JM2
31424 C  update of mother-daugther relations
31425         IF(ABS(ISTH).LE.1) THEN
31426           IF(JM1.GT.0) THEN
31427             IF(JDAHEP(1,JM1).EQ.0) THEN
31428               JDAHEP(1,JM1) = NHEP
31429               ISTHEP(JM1) = 2
31430             ENDIF
31431             JDAHEP(2,JM1) = NHEP
31432           ENDIF
31433           IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31434             IF(JDAHEP(1,JM2).EQ.0) THEN
31435               JDAHEP(1,JM2) = NHEP
31436               ISTHEP(JM2) = 2
31437             ENDIF
31438             JDAHEP(2,JM2) = NHEP
31439           ELSE IF(JM2.LT.0) THEN
31440             DO 100 II=JM1+1,-JM2
31441               IF(JDAHEP(1,II).EQ.0) THEN
31442                 JDAHEP(1,II) = NHEP
31443                 ISTHEP(II) = 2
31444               ENDIF
31445               JDAHEP(2,II) = NHEP
31446 100         CONTINUE
31447           ENDIF
31448         ENDIF
31449         PHEP(1,NHEP) = P1
31450         PHEP(2,NHEP) = P2
31451         PHEP(3,NHEP) = P3
31452         PHEP(4,NHEP) = P4
31453         IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31454           TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31455           PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31456         ELSE
31457           PHEP(5,NHEP) = 0.D0
31458         ENDIF
31459         JDAHEP(1,NHEP) = 0
31460         JDAHEP(2,NHEP) = 0
31461 C  extended information
31462         IMPART(NHEP) = IDBAMI
31463 C  extended history information
31464         IPHIST(1,NHEP) = IPHIS1
31465         IPHIST(2,NHEP) = IPHIS2
31466 C  charge/baryon number or color labels
31467         IF(ISTH.EQ.1) THEN
31468           ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31469           ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31470         ELSE
31471           ICOLOR(1,NHEP) = IC1
31472           ICOLOR(2,NHEP) = IC2
31473         ENDIF
31474
31475         IPOS = NHEP
31476         IF(IDEB(76).GE.26) THEN
31477           WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31478      &      'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31479      &      IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31480      &      PHEP(5,NHEP),IPOS
31481         ENDIF
31482
31483       ELSE IF(IMODE.EQ.0) THEN
31484         NHEP   = 0
31485       ELSE IF(IMODE.EQ.2) THEN
31486         IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31487           WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31488      &      'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31489           RETURN
31490         ENDIF
31491         ISTH  = ISTHEP(IPOS)
31492         IDPDG = IDHEP(IPOS)
31493         IDBAM = IMPART(IPOS)
31494         JM1   = JMOHEP(1,IPOS)
31495         JM2   = JMOHEP(2,IPOS)
31496         P1    = PHEP(1,IPOS)
31497         P2    = PHEP(2,IPOS)
31498         P3    = PHEP(3,IPOS)
31499         P4    = PHEP(4,IPOS)
31500         IPHIS1= IPHIST(1,IPOS)
31501         IPHIS2= IPHIST(2,IPOS)
31502         IC1   = ICOLOR(1,IPOS)
31503         IC2   = ICOLOR(2,IPOS)
31504       ELSE
31505         WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31506       ENDIF
31507       END
31508
31509 *$ CREATE IPHO_CNV1.FOR
31510 *COPY IPHO_CNV1
31511 CDECK  ID>, IPHO_CNV1
31512       INTEGER FUNCTION IPHO_CNV1(IPART)
31513 C*********************************************************************
31514 C
31515 C     conversion of quark numbering scheme to PARTICLE DATA GROUP
31516 C                                             convention
31517 C
31518 C     input:   old internal particle code of hard scattering
31519 C                    0   gluon
31520 C                    1   d
31521 C                    2   u
31522 C                    3   s
31523 C                    4   c
31524 C     valence quarks changed to standard numbering
31525 C
31526 C     output:  standard particle codes
31527 C
31528 C*********************************************************************
31529       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31530       SAVE
31531 C
31532       II = ABS(IPART)
31533 C  change gluon number
31534       IF(II.EQ.0) THEN
31535         IPHO_CNV1 = 21
31536 C  change valence quark
31537       ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31538         IPHO_CNV1 = SIGN(II-6,IPART)
31539       ELSE
31540         IPHO_CNV1 = IPART
31541       ENDIF
31542       END
31543
31544 *$ CREATE PHO_HACODE.FOR
31545 *COPY PHO_HACODE
31546 CDECK  ID>, PHO_HACODE
31547       SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31548 C*********************************************************************
31549 C
31550 C     determination of hadron index from quarks
31551 C
31552 C     input:   ID1,ID2   parton code according to PDG conventions
31553 C
31554 C     output:  IDcpc1,2  CPC particle codes
31555 C
31556 C*********************************************************************
31557       IMPLICIT NONE
31558       SAVE
31559
31560       integer ID1,ID2,IDcpc1,IDcpc2
31561
31562 C  input/output channels
31563       INTEGER LI,LO
31564       COMMON /POINOU/ LI,LO
31565 C  event debugging information
31566       INTEGER NMAXD
31567       PARAMETER (NMAXD=100)
31568       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31569      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31570       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31571      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31572 C  general particle data
31573       double precision xm_list,tau_list,gam_list,
31574      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31575      &  xm_bb82_list,xm_bb102_list
31576       integer          ich3_list,iba3_list,iq_list,
31577      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
31578       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31579      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
31580      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31581      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31582      &  ich3_list(300),iba3_list(300),iq_list(3,300),
31583      &  id_psm_list(6,6),id_vem_list(6,6),
31584      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
31585
31586 C  local variables
31587       integer ii,jj,kk,i1,i2
31588
31589       IDcpc1 = 0
31590       IDcpc2 = 0
31591
31592       if(ID1*ID2.lt.0) then
31593 C  meson
31594         if(ID1.gt.0) then
31595           ii = ID1
31596           jj = -ID2
31597         else
31598           ii = ID2
31599           jj = -ID1
31600         endif
31601         IDcpc1 = ID_psm_list(ii,jj)
31602         IDcpc2 = ID_vem_list(ii,jj)
31603
31604       else
31605 C  baryon
31606         i1 = abs(ID1)
31607         i2 = abs(ID2)
31608         if(i1.gt.6) then
31609           ii = i1/1000
31610           jj = (i1-ii*1000)/100
31611           kk = i2
31612         else
31613           ii = i1
31614           jj = i2/1000
31615           kk = (i2-jj*1000)/100
31616         endif
31617         IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31618         IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31619
31620       endif
31621
31622       END
31623
31624 *$ CREATE PHO_ID2STR.FOR
31625 *COPY PHO_ID2STR
31626 CDECK  ID>, PHO_ID2STR
31627       SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31628 C*********************************************************************
31629 C
31630 C     conversion of quark numbering scheme
31631 C
31632 C     input:   standard particle codes:
31633 C                       ID1
31634 C                       ID2
31635 C
31636 C     output:  NOBAM    CPC string code
31637 C              quark codes (PDG convention):
31638 C                       IBAM1
31639 C                       IBAM2
31640 C                       IBAM3
31641 C                       IBAM4
31642 C
31643 C              NOBAM = -1 invalid flavour combinations
31644 C
31645 C*********************************************************************
31646       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31647       SAVE
31648
31649 C  input/output channels
31650       INTEGER LI,LO
31651       COMMON /POINOU/ LI,LO
31652
31653       IDA1 = ABS(ID1)
31654       IDA2 = ABS(ID2)
31655
31656 C  quark-antiquark string
31657       IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31658         IF((ID1*ID2).GE.0) GOTO 100
31659         IBAM1 = ID1
31660         IBAM2 = ID2
31661         IBAM3 = 0
31662         IBAM4 = 0
31663         NOBAM = 3
31664 C  quark-diquark string
31665       ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31666         IF((ID1*ID2).LE.0) GOTO 100
31667         IBAM1 = ID1
31668         IBAM2 = ID2/1000
31669         IBAM3 = (ID2-IBAM2*1000)/100
31670         IBAM4 = 0
31671         NOBAM = 4
31672 C  diquark-quark string
31673       ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31674         IF((ID1*ID2).LE.0) GOTO 100
31675         IBAM1 = ID1/1000
31676         IBAM2 = (ID1-IBAM1*1000)/100
31677         IBAM3 = ID2
31678         IBAM4 = 0
31679         NOBAM = 6
31680 C  gluon-gluon string
31681       ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31682         IBAM1 = 21
31683         IBAM2 = 21
31684         IBAM3 = 0
31685         IBAM4 = 0
31686         NOBAM = 7
31687 C  diquark-antidiquark string
31688       ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31689         IF((ID1*ID2).GE.0) GOTO 100
31690         IBAM1 = ID1/1000
31691         IBAM2 = (ID1-IBAM1*1000)/100
31692         IBAM3 = ID2/1000
31693         IBAM4 = (ID2-IBAM3*1000)/100
31694         NOBAM = 5
31695       ENDIF
31696       RETURN
31697
31698 C  invalid combination
31699  100  CONTINUE
31700         WRITE(LO,'(//1X,A,2I10)')
31701      &    'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31702         CALL PHO_ABORT
31703
31704       END
31705
31706 *$ CREATE PHO_MKSLTR.FOR
31707 *COPY PHO_MKSLTR
31708 CDECK  ID>, PHO_MKSLTR
31709       SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31710 C********************************************************************
31711 C
31712 C     calculate successive Lorentz boots for arbitrary Lorentz trans.
31713 C
31714 C     input:   P1                initial 4 vector
31715 C              GAM(3),GAMB(3)    Lorentz boost parameters
31716 C
31717 C     output:  P2                final  4 vector
31718 C
31719 C********************************************************************
31720       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31721       SAVE
31722
31723       DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31724
31725       P2(4) = P1(4)
31726       DO 150 I=1,3
31727         P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31728         P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
31729  150  CONTINUE
31730       END
31731
31732 *$ CREATE PHO_GETLTR.FOR
31733 *COPY PHO_GETLTR
31734 CDECK  ID>, PHO_GETLTR
31735       SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
31736 C********************************************************************
31737 C
31738 C     calculate Lorentz boots for arbitrary Lorentz transformation
31739 C
31740 C     input:   P1    initial 4 vector
31741 C              P2    final 4 vector
31742 C
31743 C     output:  GAM(3),GAMB(3)
31744 C              DELE   energy deviation
31745 C              IREJ   0 success
31746 C                     1 failure
31747 C
31748 C********************************************************************
31749       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31750       SAVE
31751
31752       PARAMETER ( DREL = 0.001D0 )
31753
31754 C  input/output channels
31755       INTEGER LI,LO
31756       COMMON /POINOU/ LI,LO
31757
31758       DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
31759
31760       IREJ = 1
31761       DO 50 K=1,4
31762         PA(K) = P1(K)
31763         PP(K) = P1(K)
31764  50   CONTINUE
31765       PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
31766       DO 100 I=1,3
31767         PP(I) = P2(I)
31768         PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
31769         IF(PP(4).LE.0.D0) RETURN
31770         PP(4) = SQRT(PP(4))
31771         GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
31772      &             -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
31773         GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
31774         GAMB(I) = GAMB(I)*GAM(I)
31775         DO 150 K=1,4
31776           PA(K) = PP(K)
31777  150    CONTINUE
31778  100  CONTINUE
31779       DELE = P2(4)-PP(4)
31780       IREJ = 0
31781 C  consistency check
31782 *     IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
31783 *       PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
31784 *       WRITE(LO,'(/1X,A,2E12.5)')
31785 *    &    'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
31786 *       WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
31787 *       WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
31788 *       WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
31789 *       WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
31790 *     ENDIF
31791       END
31792
31793 *$ CREATE PHO_ALTRA.FOR
31794 *COPY PHO_ALTRA
31795 CDECK  ID>, PHO_ALTRA
31796       SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
31797 C*********************************************************************
31798 C
31799 C    arbitrary Lorentz transformation
31800 C
31801 C*********************************************************************
31802       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31803       SAVE
31804
31805       EP=PCX*BGX+PCY*BGY+PCZ*BGZ
31806       PE=EP/(GA+1.D0)+EC
31807       PX=PCX+BGX*PE
31808       PY=PCY+BGY*PE
31809       PZ=PCZ+BGZ*PE
31810       P=SQRT(PX*PX+PY*PY+PZ*PZ)
31811       E=GA*EC+EP
31812
31813       END
31814
31815 *$ CREATE PHO_LTRANS.FOR
31816 *COPY PHO_LTRANS
31817 CDECK  ID>, PHO_LTRANS
31818       SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
31819      &                 PL,CXL,CYL,CZL,EL)
31820 C**********************************************************************
31821 C
31822 C     Lorentz transformation into lab - system
31823 C
31824 C**********************************************************************
31825       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31826       SAVE
31827
31828       PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
31829
31830 C  input/output channels
31831       INTEGER LI,LO
31832       COMMON /POINOU/ LI,LO
31833
31834       SID=SQRT(1.D0-COD*COD)
31835       PLX=P*SID*COF
31836       PLY=P*SID*SIF
31837       PCMZ=P*COD
31838       PLZ=GAM*PCMZ+BGAM*ECM
31839       PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
31840       EL=GAM*ECM+BGAM*PCMZ
31841
31842 C  rotation into the original direction
31843       COZ=PLZ/PL
31844       SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
31845
31846 *      CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
31847
31848       AX=ABS(CX)
31849       AY=ABS(CY)
31850       IF(AX.LT.AY) THEN
31851         AMAX=AY
31852         AMIN=AX
31853       ELSE
31854         AMAX=AX
31855         AMIN=AY
31856       ENDIF
31857       IF (ABS(CX)-TINY) 1,1,2
31858     1 IF (ABS(CY)-TINY) 3,3,2
31859
31860     3 CONTINUE
31861 *     WRITE(LO,*) ' PHO_DTRANS CX CY CZ =',CX,CY,CZ
31862       CXL=SIZ*COF
31863       CYL=SIZ*SIF
31864       CZL=COZ*CZ
31865 *     WRITE(LO,*) ' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
31866 *     WRITE(LO,*) CXL,CYL,CZL
31867       RETURN
31868
31869     2 CONTINUE
31870       IF(AMAX.GT.TINY2) THEN
31871         AR=AMIN/AMAX
31872         AR=AR*AR
31873         A=AMAX*SQRT(1.D0+AR)
31874       ELSE
31875 *       WRITE(LO,*) ' PHO_DTRANS AMAX LE TINY2 '
31876         GOTO 3
31877       ENDIF
31878       XI=SIZ*COF
31879       YI=SIZ*SIF
31880       ZI=COZ
31881       CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
31882       CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
31883       CZL=A*YI+CZ*ZI
31884
31885       END
31886
31887 *$ CREATE PHO_TRANS.FOR
31888 *COPY PHO_TRANS
31889 CDECK  ID>, PHO_TRANS
31890       SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31891 C**********************************************************************
31892 C
31893 C  rotation of coordinate frame (1) de rotation around y axis
31894 C                               (2) fe rotation around z axis
31895 C  (inverse rotation to PHO_TRANI)
31896 C
31897 C**********************************************************************
31898       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31899       SAVE
31900
31901       X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
31902       Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
31903       Z=-SDE    *XO       +CDE    *ZO
31904
31905       END
31906
31907 *$ CREATE PHO_TRANI.FOR
31908 *COPY PHO_TRANI
31909 CDECK  ID>, PHO_TRANI
31910       SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31911 C**********************************************************************
31912 C
31913 C  rotation of coordinate frame (1) -fe rotation around z axis
31914 C                               (2) -de rotation around y axis
31915 C  (inverse rotation to PHO_TRANS)
31916 C
31917 C**********************************************************************
31918       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31919       SAVE
31920
31921       X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
31922       Y=-SFE    *XO+CFE*    YO
31923       Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
31924
31925       END
31926
31927 *$ CREATE pho_cpcini.FOR
31928 *COPY pho_cpcini
31929 CDECK  ID>, pho_cpcini
31930       SUBROUTINE pho_cpcini(Nrows,Number,List)
31931 C***********************************************************************
31932 C
31933 C     initialization of particle hash table
31934 C
31935 C     input:   Number     vector with Nrows entries according to PDG
31936 C                         convention
31937 C
31938 C     output:  List       vector with hash table
31939 C
31940 C     (this code is based on the function initpns written by
31941 C      Gerry Lynch, LBL, January 1990)
31942 C
31943 C***********************************************************************
31944       IMPLICIT NONE
31945       SAVE
31946
31947 C  input/output channels
31948       INTEGER LI,LO
31949       COMMON /POINOU/ LI,LO
31950
31951       integer Number(*),List(*),Nrows
31952
31953       Integer Nin,Nout,Ip,I
31954
31955       do I = 1,577
31956         List(I) = 0
31957       enddo
31958
31959 C    Loop over all of the elements in the Number vector
31960
31961         Do 500 Ip = 1,Nrows
31962             Nin = Number(Ip)
31963
31964 C    Calculate a list number for this particle id number
31965             If(Nin.Gt.99999.or.Nin.Le.0) Then
31966                  Nout = -1
31967             Else If(Nin.Le.577) Then
31968                  Nout = Nin
31969             Else
31970                  Nout = Mod(Nin,577)
31971             End If
31972
31973  200        continue
31974
31975             If(Nout.Lt.0) Then
31976 C    Count the bad entries
31977                 WRITE(LO,'(1x,a,i10)')
31978      &            'pho_cpcini: invalid particle ID',Nin
31979                 Go to 500
31980             End If
31981             If(List(Nout).eq.0) Then
31982                 List(Nout) = Ip
31983             Else
31984                 If(Nin.eq.Number(List(Nout))) Then
31985                   WRITE(LO,'(1x,a,i10)')
31986      &              'pho_cpcini: double particle ID',Nin
31987                 End If
31988                 Nout = Nout + 5
31989                 If(Nout.Gt.577) Nout = Mod(Nout, 577)
31990
31991                 Go to 200
31992             End If
31993  500      Continue
31994
31995       END
31996
31997 *$ CREATE ipho_pdg2id.FOR
31998 *COPY ipho_pdg2id
31999 CDECK  ID>, ipho_pdg2id
32000       INTEGER FUNCTION ipho_pdg2id(IDpdg)
32001 C**********************************************************************
32002 C
32003 C     calculation internal particle code using the particle index i
32004 C     according to the PDG proposal.
32005 C
32006 C     input:  IDpdg          PDG particle number
32007 C     output: ipho_pdg2id    internal particle code
32008 C                            (0 for invalid IDpdg)
32009 C
32010 C     the hash algorithm is based on a program by Gerry Lynch
32011 C
32012 C**********************************************************************
32013       IMPLICIT NONE
32014       SAVE
32015
32016       integer IDpdg
32017
32018 C  input/output channels
32019       INTEGER LI,LO
32020       COMMON /POINOU/ LI,LO
32021 C  event debugging information
32022       INTEGER NMAXD
32023       PARAMETER (NMAXD=100)
32024       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32025      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32026       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32027      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32028 C  particle ID translation table
32029       integer         ID_pdg_list,ID_list,ID_pdg_max
32030       character*12    name_list
32031       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32032      &                ID_pdg_max
32033
32034       integer Nin,Nout
32035
32036       Nin = abs(IDpdg)
32037
32038       if((Nin.gt.99999).or.(Nin.eq.0)) then
32039 C  invalid particle number
32040         if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32041      &    'ipho_pdg2id: invalid PDG ID number ',IDpdg
32042         ipho_pdg2id = 0
32043         return
32044       else If(Nin.le.577) then
32045 C  simple case
32046         Nout = Nin
32047       else
32048 C  use hash algorithm
32049         Nout = mod(Nin,577)
32050       endif
32051
32052  100  continue
32053
32054 C  particle not in table
32055       if(ID_list(Nout).Eq.0) then
32056         if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32057      &    'ipho_pdg2id: particle not in table ',IDpdg
32058         ipho_pdg2id = 0
32059         return
32060       endif
32061
32062       if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32063 C  particle ID found
32064         ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32065         return
32066       else
32067 C  increment and try again
32068         Nout = Nout + 5
32069         If(Nout.gt.577) Nout = Mod(Nout,577)
32070         goto 100
32071       endif
32072
32073       END
32074
32075 *$ CREATE IPHO_ID2PDG.FOR
32076 *COPY IPHO_ID2PDG
32077 CDECK  ID>, IPHO_ID2PDG
32078       INTEGER FUNCTION ipho_id2pdg(IDcpc)
32079 C**********************************************************************
32080 C
32081 C     conversion of internal particle code to PDG standard
32082 C
32083 C     input:     IDcpc        internal particle number
32084 C     output:    ipho_id2pdg  PDG particle number
32085 C                             (0 for invalid IDcpc)
32086 C
32087 C**********************************************************************
32088       IMPLICIT NONE
32089       SAVE
32090
32091       integer IDcpc
32092
32093 C  input/output channels
32094       INTEGER LI,LO
32095       COMMON /POINOU/ LI,LO
32096 C  event debugging information
32097       INTEGER NMAXD
32098       PARAMETER (NMAXD=100)
32099       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32100      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32101       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32102      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32103 C  particle ID translation table
32104       integer         ID_pdg_list,ID_list,ID_pdg_max
32105       character*12    name_list
32106       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32107      &                ID_pdg_max
32108
32109       integer IDabs
32110
32111       IDabs = abs(IDcpc)
32112       if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32113         ipho_id2pdg = 0
32114         return
32115       endif
32116
32117       ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32118
32119       END
32120
32121 *$ CREATE IPHO_LU2PDG.FOR
32122 *COPY IPHO_LU2PDG
32123 CDECK  ID>, IPHO_LU2PDG
32124       INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32125 C**********************************************************************
32126 C
32127 C    conversion of JETSET KF code to PDG code
32128 C
32129 C**********************************************************************
32130       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32131       SAVE
32132       PARAMETER (NTAB=10)
32133       DIMENSION LU2PD(2,NTAB)
32134       DATA LU2PD / 4232, 4322,
32135      &             4322, 4232,
32136      &             3212, 3122,
32137      &             3122, 3212,
32138      &            30553, 20553,
32139      &            30443, 20443,
32140      &            20443, 10443,
32141      &            10443, 0,
32142      &            511,   0,
32143      &            10551, 551 /
32144 C
32145       DO 100 I=1,NTAB
32146         IF(LU2PD(1,I).EQ.LUKF) THEN
32147           IPHO_LU2PDG=LU2PD(2,I)
32148           RETURN
32149         ENDIF
32150  100  CONTINUE
32151       IPHO_LU2PDG=LUKF
32152
32153       END
32154
32155 *$ CREATE IPHO_PDG2LU.FOR
32156 *COPY IPHO_PDG2LU
32157 CDECK  ID>, IPHO_PDG2LU
32158       INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32159 C**********************************************************************
32160 C
32161 C    conversion of PDG code to JETSET code
32162 C
32163 C**********************************************************************
32164       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32165       SAVE
32166       PARAMETER (NTAB=8)
32167       DIMENSION LU2PD(2,NTAB)
32168       DATA LU2PD / 4232, 4322,
32169      &             4322, 4232,
32170      &             3212, 3122,
32171      &             3122, 3212,
32172      &            30553, 20553,
32173      &            30443, 20443,
32174      &            20443, 10443,
32175      &            10551, 551 /
32176 C
32177       DO 100 I=1,NTAB
32178         IF(LU2PD(2,I).EQ.IPDG) THEN
32179           IPHO_PDG2LU=LU2PD(1,I)
32180           RETURN
32181         ENDIF
32182  100  CONTINUE
32183       IPHO_PDG2LU=IPDG
32184
32185       END
32186
32187 *$ CREATE pho_pname.FOR
32188 *COPY pho_pname
32189 CDECK  ID>, pho_pname
32190       CHARACTER*15 FUNCTION pho_pname(ID,mode)
32191 C***********************************************************************
32192 C
32193 C     returns particle name for given ID number
32194 C
32195 C     input:  ID      particle ID number
32196 C             mode    0:   ID treated as compressed particle code
32197 C                     1:   ID treated as PDG number
32198 C
32199 C***********************************************************************
32200       IMPLICIT NONE
32201       SAVE
32202
32203       integer ID,mode
32204
32205 C  input/output channels
32206       INTEGER LI,LO
32207       COMMON /POINOU/ LI,LO
32208 C  standard particle data interface
32209       INTEGER NMXHEP
32210       PARAMETER (NMXHEP=4000)
32211       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32212       DOUBLE PRECISION PHEP,VHEP
32213       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32214      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32215      &                VHEP(4,NMXHEP)
32216 C  extension to standard particle data interface (PHOJET specific)
32217       INTEGER IMPART,IPHIST,ICOLOR
32218       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32219 C  particle ID translation table
32220       integer         ID_pdg_list,ID_list,ID_pdg_max
32221       character*12    name_list
32222       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32223      &                ID_pdg_max
32224 C  general particle data
32225       double precision xm_list,tau_list,gam_list,
32226      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32227      &  xm_bb82_list,xm_bb102_list
32228       integer          ich3_list,iba3_list,iq_list,
32229      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32230       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32231      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32232      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32233      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32234      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32235      &  id_psm_list(6,6),id_vem_list(6,6),
32236      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32237
32238 C  external functions
32239       integer ipho_id2pdg,ipho_pdg2id
32240
32241 C  local variables
32242       integer  IDpdg,i,ii,k,l,ichar,i_anti
32243       character*15 name
32244
32245       pho_pname = '(?????????????)'
32246
32247       if(mode.eq.0) then
32248         i = ID
32249         IDpdg = ipho_id2pdg(ID)
32250         if(IDpdg.eq.0) return
32251       else if(mode.eq.1) then
32252         i = ipho_pdg2id(ID)
32253         if(i.eq.0) return
32254         IDpdg = ID
32255       else if(mode.eq.2) then
32256         if(ISTHEP(ID).gt.11) then
32257           if(ISTHEP(ID).eq.20) then
32258             pho_pname = 'hard ini. part.'
32259           else if(ISTHEP(ID).eq.21) then
32260             pho_pname = 'hard fin. part.'
32261           else if(ISTHEP(ID).eq.25) then
32262             pho_pname = 'hard scattering'
32263           else if(ISTHEP(ID).eq.30) then
32264             pho_pname = 'diff. diss.    '
32265           else if(ISTHEP(ID).eq.35) then
32266             pho_pname = 'elastic scatt. '
32267           else if(ISTHEP(ID).eq.40) then
32268             pho_pname = 'central scatt. '
32269           endif
32270           return
32271         endif
32272         IDpdg = IDHEP(ID)
32273         i     = IMPART(ID)
32274       else
32275         WRITE(LO,'(1x,a,2i4)')
32276      &    'pho_pname: invalid arguments (ID,mode): ',ID,mode
32277         return
32278       endif
32279
32280       ii = abs(i)
32281       if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32282
32283       name = name_list(ii)
32284       ichar = ich3_list(ii)*sign(1,i)
32285       if(mod(ichar,3).ne.0) then
32286         ichar = 0
32287       else
32288         ichar = ichar/3
32289       endif
32290
32291 C  find position of first blank character
32292       k = 1
32293  100  continue
32294         k = k+1
32295       if(name(k:k).ne.' ') goto 100
32296
32297 C  append anti-particle sign
32298       if(i.lt.0) then
32299         i_anti = 0
32300         do l=1,3
32301           i_anti = i_anti+iq_list(l,ii)
32302         enddo
32303         if(iba3_list(ii).ne.0) then
32304           name(k:k) = '~'
32305           k = K+1
32306         else if(((i_anti.ne.0).and.(ichar.eq.0))
32307      &          .or.(IDpdg.eq.-12)
32308      &          .or.(IDpdg.eq.-14)
32309      &          .or.(IDpdg.eq.-16)) then
32310           name(k:k) = '~'
32311           k = K+1
32312         endif
32313       endif
32314
32315 C  append charge sign
32316       if(ichar.eq.-2) then
32317         name(k:k+1) = '--'
32318       else if(ichar.eq.-1) then
32319         name(k:k) = '-'
32320       else if(ichar.eq.1) then
32321         name(k:k) = '+'
32322       else if(ichar.eq.2) then
32323         name(k:k+1) = '++'
32324       endif
32325
32326       pho_pname = name
32327
32328       END
32329
32330 *$ CREATE ipho_anti.FOR
32331 *COPY ipho_anti
32332 CDECK  ID>, ipho_anti
32333       INTEGER FUNCTION ipho_anti(ID)
32334 C**********************************************************************
32335 C
32336 C     determine antiparticle for given ID
32337 C
32338 C     input:  ID gives CPC particle number
32339 C
32340 C     output: ipho_anti antiparticle code
32341 C
32342 C**********************************************************************
32343       IMPLICIT NONE
32344       SAVE
32345
32346       integer ID
32347
32348 C  input/output channels
32349       INTEGER LI,LO
32350       COMMON /POINOU/ LI,LO
32351 C  event debugging information
32352       INTEGER NMAXD
32353       PARAMETER (NMAXD=100)
32354       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32355      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32356       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32357      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32358 C  particle ID translation table
32359       integer         ID_pdg_list,ID_list,ID_pdg_max
32360       character*12    name_list
32361       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32362      &                ID_pdg_max
32363 C  general particle data
32364       double precision xm_list,tau_list,gam_list,
32365      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32366      &  xm_bb82_list,xm_bb102_list
32367       integer          ich3_list,iba3_list,iq_list,
32368      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32369       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32370      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32371      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32372      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32373      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32374      &  id_psm_list(6,6),id_vem_list(6,6),
32375      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32376 C  standard particle data interface
32377       INTEGER NMXHEP
32378       PARAMETER (NMXHEP=4000)
32379       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32380       DOUBLE PRECISION PHEP,VHEP
32381       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32382      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32383      &                VHEP(4,NMXHEP)
32384 C  extension to standard particle data interface (PHOJET specific)
32385       INTEGER IMPART,IPHIST,ICOLOR
32386       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32387
32388 C  external functions
32389       integer ipho_id2pdg,ipho_pdg2id
32390
32391 C  local variables
32392       integer IDabs,IDpdg,i_anti,l
32393
32394       ipho_anti = -ID
32395       IDabs = abs(ID)
32396
32397 C  baryons
32398       if(iba3_list(IDabs).ne.0) return
32399
32400 C  charged particles
32401       if(ich3_list(IDabs).ne.0) return
32402
32403 C  K0_s and K0_l
32404       IDpdg = ipho_id2pdg(ID)
32405       if(IDpdg.eq.310) then
32406         ID = ipho_pdg2id(130)
32407         return
32408       else if(IDpdg.eq.130) then
32409         ID = ipho_pdg2id(310)
32410         return
32411       endif
32412
32413 C  neutral mesons with open strangeness, charm, or beauty
32414       i_anti = 0
32415       do l=1,3
32416         i_anti = i_anti+iq_list(l,IDabs)
32417       enddo
32418       if(i_anti.ne.0) return
32419
32420 C  neutrinos
32421       IDpdg = abs(IDpdg)
32422       if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32423
32424       ipho_anti = ID
32425
32426       END
32427
32428 *$ CREATE ipho_chr3.FOR
32429 *COPY ipho_chr3
32430 CDECK  ID>, ipho_chr3
32431       INTEGER FUNCTION ipho_chr3(ID,mode)
32432 C**********************************************************************
32433 C
32434 C     output of three times the electric charge
32435 C
32436 C     input:  mode
32437 C             0   ID gives CPC particle number
32438 C             1   ID gives PDG particle number
32439 C             2   ID gives position of particle in /POEVT1/
32440 C
32441 C**********************************************************************
32442       IMPLICIT NONE
32443       SAVE
32444
32445       integer ID,mode
32446
32447 C  input/output channels
32448       INTEGER LI,LO
32449       COMMON /POINOU/ LI,LO
32450 C  event debugging information
32451       INTEGER NMAXD
32452       PARAMETER (NMAXD=100)
32453       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32454      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32455       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32456      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32457 C  standard particle data interface
32458       INTEGER NMXHEP
32459       PARAMETER (NMXHEP=4000)
32460       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32461       DOUBLE PRECISION PHEP,VHEP
32462       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32463      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32464      &                VHEP(4,NMXHEP)
32465 C  extension to standard particle data interface (PHOJET specific)
32466       INTEGER IMPART,IPHIST,ICOLOR
32467       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32468 C  particle ID translation table
32469       integer         ID_pdg_list,ID_list,ID_pdg_max
32470       character*12    name_list
32471       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32472      &                ID_pdg_max
32473 C  general particle data
32474       double precision xm_list,tau_list,gam_list,
32475      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32476      &  xm_bb82_list,xm_bb102_list
32477       integer          ich3_list,iba3_list,iq_list,
32478      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32479       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32480      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32481      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32482      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32483      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32484      &  id_psm_list(6,6),id_vem_list(6,6),
32485      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32486
32487 C  external functions
32488       integer ipho_pdg2id
32489
32490 C  local variables
32491       integer i,IDpdg
32492
32493       ipho_chr3 = 0
32494
32495       if(mode.eq.0) then
32496         i = ID
32497       else if(mode.eq.1) then
32498         i = ipho_pdg2id(ID)
32499         if(i.eq.0) return
32500         IDpdg = ID
32501       else if(mode.eq.2) then
32502         if(ISTHEP(ID).gt.11) return
32503         i     = IMPART(ID)
32504         IDpdg = IDHEP(ID)
32505         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32506           ipho_chr3 = ICOLOR(1,ID)
32507           return
32508         endif
32509       else
32510         WRITE(LO,'(1x,a,2i4)')
32511      &    'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32512         return
32513       endif
32514
32515       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32516         WRITE(LO,'(1x,a,3i8)')
32517      &    'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32518         ipho_chr3 = 1.D0/dble(i)
32519         call pho_prevnt(0)
32520         return
32521       endif
32522
32523       ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32524
32525       END
32526
32527 *$ CREATE ipho_bar3.FOR
32528 *COPY ipho_bar3
32529 CDECK  ID>, ipho_bar3
32530       INTEGER FUNCTION ipho_bar3(ID,mode)
32531 C**********************************************************************
32532 C
32533 C     output of three times the baryon charge
32534 C
32535 C     index:  MODE
32536 C             0   ID gives CPC particle number
32537 C             1   ID gives PDG particle number
32538 C             2   ID gives position of particle in /POEVT1/
32539 C
32540 C**********************************************************************
32541       IMPLICIT NONE
32542       SAVE
32543
32544       integer ID,mode
32545
32546 C  input/output channels
32547       INTEGER LI,LO
32548       COMMON /POINOU/ LI,LO
32549 C  event debugging information
32550       INTEGER NMAXD
32551       PARAMETER (NMAXD=100)
32552       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32553      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32554       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32555      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32556 C  standard particle data interface
32557       INTEGER NMXHEP
32558       PARAMETER (NMXHEP=4000)
32559       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32560       DOUBLE PRECISION PHEP,VHEP
32561       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32562      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32563      &                VHEP(4,NMXHEP)
32564 C  extension to standard particle data interface (PHOJET specific)
32565       INTEGER IMPART,IPHIST,ICOLOR
32566       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32567 C  particle ID translation table
32568       integer         ID_pdg_list,ID_list,ID_pdg_max
32569       character*12    name_list
32570       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32571      &                ID_pdg_max
32572 C  general particle data
32573       double precision xm_list,tau_list,gam_list,
32574      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32575      &  xm_bb82_list,xm_bb102_list
32576       integer          ich3_list,iba3_list,iq_list,
32577      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32578       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32579      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32580      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32581      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32582      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32583      &  id_psm_list(6,6),id_vem_list(6,6),
32584      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32585
32586 C  external functions
32587       integer ipho_pdg2id
32588
32589 C  local variables
32590       integer i,IDpdg
32591
32592       ipho_bar3 = 0
32593
32594       if(mode.eq.0) then
32595         i = ID
32596       else if(mode.eq.1) then
32597         i = ipho_pdg2id(ID)
32598         if(i.eq.0) return
32599         IDpdg = ID
32600       else if(mode.eq.2) then
32601         if(ISTHEP(ID).gt.11) return
32602         i     = IMPART(ID)
32603         IDpdg = IDHEP(ID)
32604         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32605           ipho_bar3 = ICOLOR(2,ID)
32606           return
32607         endif
32608       else
32609         WRITE(LO,'(1x,a,2i4)')
32610      &    'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32611         return
32612       endif
32613
32614       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32615         WRITE(LO,'(1x,a,3i8)')
32616      &    'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32617         ipho_bar3 = 1.D0/dble(i)
32618         return
32619       endif
32620
32621       ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32622
32623       END
32624
32625 *$ CREATE pho_pmass.FOR
32626 *COPY pho_pmass
32627 CDECK  ID>, pho_pmass
32628       DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32629 C***********************************************************************
32630 C
32631 C     particle mass
32632 C
32633 C     input:  mode  -1   initialization
32634 C                    0   ID gives CPC particle number
32635 C                    1   ID gives PDG particle number,
32636 C                        (for quarks current masses are returned)
32637 C                    2   ID gives position of particle in /POEVT1/
32638 C                    3   ID gives PDG parton number,
32639 C                        (for quarks constituent masses are returned)
32640 C
32641 C     output: average particle mass (in GeV)
32642 C
32643 C***********************************************************************
32644       IMPLICIT NONE
32645       SAVE
32646
32647       integer ID,mode,MSTJ24
32648
32649 C  input/output channels
32650       INTEGER LI,LO
32651       COMMON /POINOU/ LI,LO
32652 C  event debugging information
32653       INTEGER NMAXD
32654       PARAMETER (NMAXD=100)
32655       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32656      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32657       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32658      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32659 C  model switches and parameters
32660       CHARACTER*8 MDLNA
32661       INTEGER ISWMDL,IPAMDL
32662       DOUBLE PRECISION PARMDL
32663       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32664 C  standard particle data interface
32665       INTEGER NMXHEP
32666       PARAMETER (NMXHEP=4000)
32667       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32668       DOUBLE PRECISION PHEP,VHEP
32669       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32670      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32671      &                VHEP(4,NMXHEP)
32672 C  extension to standard particle data interface (PHOJET specific)
32673       INTEGER IMPART,IPHIST,ICOLOR
32674       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32675 C  particle ID translation table
32676       integer         ID_pdg_list,ID_list,ID_pdg_max
32677       character*12    name_list
32678       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32679      &                ID_pdg_max
32680 C  general particle data
32681       double precision xm_list,tau_list,gam_list,
32682      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32683      &  xm_bb82_list,xm_bb102_list
32684       integer          ich3_list,iba3_list,iq_list,
32685      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32686       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32687      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32688      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32689      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32690      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32691      &  id_psm_list(6,6),id_vem_list(6,6),
32692      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32693       INTEGER MSTU,MSTJ
32694       DOUBLE PRECISION PARU,PARJ
32695       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32696
32697 C  external functions
32698       integer ipho_pdg2id,ipho_id2pdg
32699       DOUBLE PRECISION PYMASS
32700
32701 C  local variables
32702       integer i,IDpdg
32703
32704       pho_pmass = 0.D0
32705
32706       if(mode.eq.0) then
32707         i = ID
32708       else if(mode.eq.1) then
32709         i = ipho_pdg2id(ID)
32710         if(i.eq.0) return
32711       else if(mode.eq.2) then
32712         if(ISTHEP(ID).gt.11) return
32713         i     = IMPART(ID)
32714         IDpdg = IDHEP(ID)
32715         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32716           pho_pmass = PHEP(5,ID)
32717           return
32718         endif
32719       else if(mode.eq.3) then
32720         i = abs(ID)
32721         if((i.gt.0).and.(i.le.6)) then
32722           pho_pmass = PARMDL(150+i)
32723           return
32724         else
32725           i = ipho_pdg2id(ID)
32726           if(i.eq.0) return
32727         endif
32728       else if(mode.eq.-1) then
32729 C  initialization: take masses for quarks and di-quarks from JETSET
32730         MSTJ24 = MSTJ(24)
32731         MSTJ(24) = 0
32732         do i=1,22
32733           IDpdg = ipho_id2pdg(i)
32734           xm_list(i) = PYMASS(IDpdg)
32735         enddo
32736         MSTJ(24) = MSTJ24
32737         return
32738       else
32739         WRITE(LO,'(1x,a,2i4)')
32740      &    'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32741         return
32742       endif
32743
32744       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32745         WRITE(LO,'(1x,a,2i8)')
32746      &    'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32747         pho_pmass = 1.D0/dble(i)
32748         return
32749       endif
32750
32751       pho_pmass = xm_list(iabs(i))
32752
32753       END
32754
32755 *$ CREATE PHO_MEMASS.FOR
32756 *COPY PHO_MEMASS
32757 CDECK  ID>, PHO_MEMASS
32758       SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
32759 C**********************************************************************
32760 C
32761 C     determine meson masses corresponding to the input flavours
32762 C
32763 C     input: I,J,K     quark flavours (PDG convention)
32764 C
32765 C     output: AMPS     pseudo scalar meson mass
32766 C             AMPS2    next possible two particle configuration
32767 C                      (two pseudo scalar  mesons)
32768 C             AMVE     vector meson mass
32769 C             AMVE2    next possible two particle configuration
32770 C                      (two vector mesons)
32771 C             IPS,IVE  meson numbers in CPC
32772 C
32773 C**********************************************************************
32774       IMPLICIT NONE
32775       SAVE
32776
32777       integer I,J,IPS,IVE
32778       double precision AMPS,AMPS2,AMVE,AMVE2
32779
32780 C  input/output channels
32781       INTEGER LI,LO
32782       COMMON /POINOU/ LI,LO
32783 C  event debugging information
32784       INTEGER NMAXD
32785       PARAMETER (NMAXD=100)
32786       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32787      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32788       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32789      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32790 C  particle ID translation table
32791       integer         ID_pdg_list,ID_list,ID_pdg_max
32792       character*12    name_list
32793       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32794      &                ID_pdg_max
32795 C  general particle data
32796       double precision xm_list,tau_list,gam_list,
32797      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32798      &  xm_bb82_list,xm_bb102_list
32799       integer          ich3_list,iba3_list,iq_list,
32800      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32801       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32802      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32803      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32804      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32805      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32806      &  id_psm_list(6,6),id_vem_list(6,6),
32807      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32808
32809 C  local variables
32810       integer ii,jj
32811
32812       IF(I.GT.0) THEN
32813         ii = I
32814         jj = -J
32815       ELSE
32816         ii = J
32817         jj = -I
32818       ENDIF
32819
32820 C  particle ID's
32821       IPS = id_psm_list(ii,jj)
32822       IVE = id_vem_list(ii,jj)
32823 C  masses
32824       if(IPS.ne.0) then
32825         AMPS = xm_list(iabs(IPS))
32826       else
32827         AMPS = 0.D0
32828       endif
32829       if(IVE.ne.0) then
32830         AMVE = xm_list(iabs(IVE))
32831       else
32832         AMVE = 0.D0
32833       endif
32834
32835 C  next possible two-particle configurations (add phase space)
32836       AMPS2 = xm_psm2_list(ii,jj)*1.5D0
32837       AMVE2 = xm_vem2_list(ii,jj)*1.1D0
32838
32839       END
32840
32841 *$ CREATE PHO_BAMASS.FOR
32842 *COPY PHO_BAMASS
32843 CDECK  ID>, PHO_BAMASS
32844       SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
32845 C**********************************************************************
32846 C
32847 C     determine baryon masses corresponding to the input flavours
32848 C
32849 C     input: I,J,K     quark flavours (PDG convention)
32850 C
32851 C     output: AM8      octett baryon mass
32852 C             AM82     next possible two particle configuration
32853 C                      (octett baryon and meson)
32854 C             AM10     decuplett baryon mass
32855 C             AM102    next possible two particle configuration
32856 C                      (decuplett baryon and meson,
32857 C                       baryon built up from first two quarks)
32858 C             I8,I10   internal baryon numbers
32859 C
32860 C**********************************************************************
32861       IMPLICIT NONE
32862       SAVE
32863
32864       integer I,J,K,I8,I10
32865       double precision AM8,AM82,AM10,AM102
32866
32867 C  input/output channels
32868       INTEGER LI,LO
32869       COMMON /POINOU/ LI,LO
32870 C  event debugging information
32871       INTEGER NMAXD
32872       PARAMETER (NMAXD=100)
32873       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32874      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32875       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32876      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32877 C  particle ID translation table
32878       integer         ID_pdg_list,ID_list,ID_pdg_max
32879       character*12    name_list
32880       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32881      &                ID_pdg_max
32882 C  general particle data
32883       double precision xm_list,tau_list,gam_list,
32884      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32885      &  xm_bb82_list,xm_bb102_list
32886       integer          ich3_list,iba3_list,iq_list,
32887      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32888       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32889      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32890      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32891      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32892      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32893      &  id_psm_list(6,6),id_vem_list(6,6),
32894      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32895
32896 C  local variables
32897       integer ii,jj,kk
32898
32899 C  find particle ID's
32900       ii = iabs(I)
32901       jj = iabs(J)
32902       kk = iabs(K)
32903       I8  = id_b8_list(ii,jj,kk)
32904       I10 = id_b10_list(ii,jj,kk)
32905
32906 C  masses (if combination possible)
32907       if(I8.ne.0) then
32908         AM8 = xm_list(I8)
32909         I8  = sign(I8,i)
32910       else
32911         AM8 = 0.D0
32912       endif
32913       if(I10.ne.0) then
32914         AM10 = xm_list(I10)
32915         I10  = sign(I10,i)
32916       else
32917         AM10 = 0.D0
32918       endif
32919
32920 C  next possible two-particle configurations (add phase space)
32921       AM82  = xm_b82_list(ii,jj,kk)*1.5D0
32922       AM102 = xm_b102_list(ii,jj,kk)*1.1D0
32923
32924       END
32925
32926 *$ CREATE PHO_DQMASS.FOR
32927 *COPY PHO_DQMASS
32928 CDECK  ID>, PHO_DQMASS
32929       SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
32930 C**********************************************************************
32931 C
32932 C     determine minimal masses corresponding to the input flavours
32933 C     (diquark a-diquark string system)
32934 C
32935 C     input: I,J,K,L   quark flavours (PDG convention)
32936 C
32937 C     output: AM82     mass of two octett baryons
32938 C             AM102    mass of two decuplett baryons
32939 C
32940 C**********************************************************************
32941       IMPLICIT NONE
32942       SAVE
32943
32944       integer I,J,K,L
32945       double precision AM82,AM102
32946
32947 C  input/output channels
32948       INTEGER LI,LO
32949       COMMON /POINOU/ LI,LO
32950 C  event debugging information
32951       INTEGER NMAXD
32952       PARAMETER (NMAXD=100)
32953       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32954      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32955       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32956      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32957 C  general particle data
32958       double precision xm_list,tau_list,gam_list,
32959      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32960      &  xm_bb82_list,xm_bb102_list
32961       integer          ich3_list,iba3_list,iq_list,
32962      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32963       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32964      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32965      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32966      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32967      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32968      &  id_psm_list(6,6),id_vem_list(6,6),
32969      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32970
32971 C  local variables
32972       integer ii,jj,kk,ll
32973
32974       ii = iabs(i)
32975       kk = iabs(k)
32976       jj = iabs(j)
32977       ll = iabs(l)
32978
32979       AM82  = xm_bb82_list(ii,jj,kk,ll)
32980       AM102 = xm_bb102_list(ii,jj,kk,ll)
32981
32982       END
32983
32984 *$ CREATE PHO_CHECK.FOR
32985 *COPY PHO_CHECK
32986 CDECK  ID>, PHO_CHECK
32987       SUBROUTINE PHO_CHECK(MD,IDEV)
32988 C**********************************************************************
32989 C
32990 C     check quantum numbers of entries in /POEVT1/ and /POEVT2/
32991 C           (energy, momentum, charge, baryon number conservation)
32992 C
32993 C     input:    MD      -1  check overall momentum conservation
32994 C                           and perform detailed check only in case of
32995 C                           deviations
32996 C                        1  test all branchings, mother-daughter
32997 C                           relations
32998 C
32999 C     output:   IDEV     0  no deviations
33000 C                        1  deviations found
33001 C
33002 C**********************************************************************
33003       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33004       SAVE
33005
33006 C  input/output channels
33007       INTEGER LI,LO
33008       COMMON /POINOU/ LI,LO
33009 C  event debugging information
33010       INTEGER NMAXD
33011       PARAMETER (NMAXD=100)
33012       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33013      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33014       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33015      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33016 C  model switches and parameters
33017       CHARACTER*8 MDLNA
33018       INTEGER ISWMDL,IPAMDL
33019       DOUBLE PRECISION PARMDL
33020       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33021 C  global event kinematics and particle IDs
33022       INTEGER IFPAP,IFPAB
33023       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33024       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33025 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
33026       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33027       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33028       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33029      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33030 C  standard particle data interface
33031       INTEGER NMXHEP
33032       PARAMETER (NMXHEP=4000)
33033       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33034       DOUBLE PRECISION PHEP,VHEP
33035       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33036      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33037      &                VHEP(4,NMXHEP)
33038 C  extension to standard particle data interface (PHOJET specific)
33039       INTEGER IMPART,IPHIST,ICOLOR
33040       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33041 C  color string configurations including collapsed strings and hadrons
33042       INTEGER MSTR
33043       PARAMETER (MSTR=500)
33044       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33045       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33046      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33047      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33048
33049 C  count number of errors to avoid disk overflow
33050       DATA IERR / 0 /
33051
33052       IDEV = 0
33053 C  conservation check suppressed
33054       IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33055
33056       IF(IPAMDL(13).GT.0) THEN
33057
33058 C  DPMJET call with x limitations
33059         MODE = -1
33060         ECM1 = SQRT(XPSUB*XTSUB)*ECM
33061
33062       ELSE
33063
33064 C  standard call
33065         MODE = MD
33066 C  first two entries are considered as scattering particles
33067         EE1 = PHEP(4,1) + PHEP(4,2)
33068         PX1 = PHEP(1,1) + PHEP(1,2)
33069         PY1 = PHEP(2,1) + PHEP(2,2)
33070         PZ1 = PHEP(3,1) + PHEP(3,2)
33071
33072       ENDIF
33073
33074       DDREL = PARMDL(75)
33075       DDABS = PARMDL(76)
33076       IF(MODE.EQ.-1) GOTO 500
33077
33078  50   CONTINUE
33079
33080       I = 1
33081  100  CONTINUE
33082
33083 C  recognize only decayed particles as mothers
33084         IF(ISTHEP(I).EQ.2) THEN
33085 C  search for other mother particles
33086           K = JDAHEP(1,I)
33087           IF(K.EQ.0) THEN
33088             IF(IPAMDL(178).NE.0)
33089      &        WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33090      &        'entry marked as decayed but no dauther given:',I
33091             GOTO 99
33092           ENDIF
33093           K1 = JMOHEP(1,K)
33094           K2 = JMOHEP(2,K)
33095 C  sum over mother particles
33096           ICH1 = IPHO_CHR3(K1,2)
33097           IBA1 = IPHO_BAR3(K1,2)
33098           EE1 = PHEP(4,K1)
33099           PX1 = PHEP(1,K1)
33100           PY1 = PHEP(2,K1)
33101           PZ1 = PHEP(3,K1)
33102           IF(K2.LT.0) THEN
33103             K2 = -K2
33104             IF((K1.GT.I).OR.(K2.LT.I)) THEN
33105               WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33106      &          'inconsistent mother/daughter relation found',I,K1,K2
33107               CALL PHO_PREVNT(-1)
33108             ENDIF
33109             DO 400 II=K1+1,K2
33110               IF(ABS(ISTHEP(II)).LE.2) THEN
33111                 ICH1 = ICH1 + IPHO_CHR3(II,2)
33112                 IBA1 = IBA1 + IPHO_BAR3(II,2)
33113                 EE1 = EE1 + PHEP(4,II)
33114                 PX1 = PX1 + PHEP(1,II)
33115                 PY1 = PY1 + PHEP(2,II)
33116                 PZ1 = PZ1 + PHEP(3,II)
33117               ENDIF
33118  400        CONTINUE
33119           ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33120             ICH1 = ICH1 + IPHO_CHR3(K2,2)
33121             IBA1 = IBA1 + IPHO_BAR3(K2,2)
33122             EE1 = EE1 + PHEP(4,K2)
33123             PX1 = PX1 + PHEP(1,K2)
33124             PY1 = PY1 + PHEP(2,K2)
33125             PZ1 = PZ1 + PHEP(3,K2)
33126           ENDIF
33127
33128 C  sum over daughter particles
33129           ICH2 = 0.D0
33130           IBA2 = 0.D0
33131           EE2 = 0.D0
33132           PX2 = 0.D0
33133           PY2 = 0.D0
33134           PZ2 = 0.D0
33135           DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33136             IF(ABS(ISTHEP(II)).LE.2) THEN
33137               ICH2 = ICH2 + IPHO_CHR3(II,2)
33138               IBA2 = IBA2 + IPHO_BAR3(II,2)
33139               EE2 = EE2 + PHEP(4,II)
33140               PX2 = PX2 + PHEP(1,II)
33141               PY2 = PY2 + PHEP(2,II)
33142               PZ2 = PZ2 + PHEP(3,II)
33143             ENDIF
33144  200      CONTINUE
33145
33146 C  conservation check
33147           ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33148           IF(ABS(EE1-EE2).GT.ESC) THEN
33149             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33150      &        'PHO_CHECK: energy conservation violated for',
33151      &        'entry,initial,final:',I,EE1,EE2
33152             IDEV = 1
33153           ENDIF
33154           ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33155           IF(ABS(PX1-PX2).GT.ESC) THEN
33156             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33157      &        'PHO_CHECK: x-momentum conservation violated for',
33158      &        'entry,initial,final:',I,PX1,PX2
33159             IDEV = 1
33160           ENDIF
33161           ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33162           IF(ABS(PY1-PY2).GT.ESC) THEN
33163             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33164      &        'PHO_CHECK: y-momentum conservation violated for',
33165      &        'entry,initial,final:',I,PY1,PY2
33166             IDEV = 1
33167           ENDIF
33168           ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33169           IF(ABS(PZ1-PZ2).GT.ESC) THEN
33170             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33171      &        'PHO_CHECK: z-momentum conservation violated for',
33172      &        'entry,initial,final:',I,PZ1,PZ2
33173             IDEV = 1
33174           ENDIF
33175           IF(ICH1.NE.ICH2) THEN
33176             WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33177      &        'PHO_CHECK: charge conservation violated for',
33178      &        'entry,initial,final:',I,ICH1,ICH2
33179             IDEV = 1
33180           ENDIF
33181           IF(IBA1.NE.IBA2) THEN
33182             WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33183      &        'baryon charge conservation violated for',
33184      &        'entry,initial,final:',I,IBA1,IBA2
33185             IDEV = 1
33186           ENDIF
33187           IF(IDEB(20).GE.35) THEN
33188             WRITE(LO,
33189      &        '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33190      &      'PHO_CHECK diagnostics:',
33191      &      '(1.mother/l.mother,1.daughter/l.daughter):',
33192      &      K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33193      &      'mother momenta   ',PX1,PY1,PZ1,EE1,
33194      &      'daughter momenta ',PX2,PY2,PZ2,EE2,
33195      &      'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33196           ENDIF
33197         ENDIF
33198  99     CONTINUE
33199         I = I+1
33200       IF(I.LE.NHEP) GOTO 100
33201
33202  55   CONTINUE
33203
33204       IERR = IERR+IDEV
33205
33206 C  write complete event in case of deviations
33207       IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33208         CALL PHO_PREVNT(1)
33209         IF(ISTR.GT.0) THEN
33210           CALL PHO_PRSTRG
33211           IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33212         ENDIF
33213       ENDIF
33214
33215 C  stop after too many errors
33216       IF(IERR.GT.IPAMDL(179)) THEN
33217         WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33218      &    'too many inconsistencies found, program terminated',IERR
33219         CALL PHO_ABORT
33220       ENDIF
33221
33222       RETURN
33223
33224 C  overall check only (less time consuming)
33225
33226  500  CONTINUE
33227
33228       ICH2 = 0.D0
33229       IBA2 = 0.D0
33230       EE2 = 0.D0
33231       PX2 = 0.D0
33232       PY2 = 0.D0
33233       PZ2 = 0.D0
33234
33235       DO 300 K=3,NHEP
33236 C  recognize only existing particles as possible daughters
33237         IF(ABS(ISTHEP(K)).EQ.1) THEN
33238           ICH2 = ICH2 + IPHO_CHR3(K,2)
33239           IBA2 = IBA2 + IPHO_BAR3(K,2)
33240           EE2 = EE2 + PHEP(4,K)
33241           PX2 = PX2 + PHEP(1,K)
33242           PY2 = PY2 + PHEP(2,K)
33243           PZ2 = PZ2 + PHEP(3,K)
33244         ENDIF
33245  300  CONTINUE
33246
33247 C  check energy-momentum conservation
33248       ESC = ECM*DDREL
33249
33250       IF(IPAMDL(13).GT.0) THEN
33251
33252 C  DPMJET call with x limitations
33253         ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33254         IF(ABS(ECM1-ECM2).GT.ESC) THEN
33255           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33256      &      'PHO_CHECK: c.m. energy conservation violated',
33257      &      'initial/final energy:',ECM1,ECM2
33258           IDEV = 1
33259         ENDIF
33260
33261       ELSE
33262
33263 C  standard call
33264         IF(ABS(EE1-EE2).GT.ESC) THEN
33265           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33266      &      'PHO_CHECK: energy conservation violated',
33267      &      'initial/final energy:',EE1,EE2
33268           IDEV = 1
33269         ENDIF
33270         IF(ABS(PX1-PX2).GT.ESC) THEN
33271         WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33272      &      'PHO_CHECK: x-momentum conservation violated',
33273      &      'initial/final x-momentum:',PX1,PX2
33274           IDEV = 1
33275         ENDIF
33276         IF(ABS(PY1-PY2).GT.ESC) THEN
33277           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33278      &      'PHO_CHECK: y-momentum conservation violated',
33279      &      'initial/final y-momentum:',PY1,PY2
33280           IDEV = 1
33281         ENDIF
33282         IF(ABS(PZ1-PZ2).GT.ESC) THEN
33283           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33284      &      'PHO_CHECK: z-momentum conservation violated',
33285      &      'initial/final z-momentum:',PZ1,PZ2
33286           IDEV = 1
33287         ENDIF
33288
33289 C  check of quantum number conservation
33290
33291         ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33292         IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33293
33294         IF(ICH1.NE.ICH2) THEN
33295           WRITE(LO,'(1X,A,/,5X,A,2I5)')
33296      &      'PHO_CHECK: charge conservation violated',
33297      &      'initial/final charge sum',ICH1,ICH2
33298           IDEV = 1
33299         ENDIF
33300         IF(IBA1.NE.IBA2) THEN
33301           WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33302      &      'baryonic charge conservation violated',
33303      &      'initial/final baryonic charge sum',IBA1,IBA2
33304           IDEV = 1
33305         ENDIF
33306
33307       ENDIF
33308
33309 C  perform detailed checks in case of deviations
33310       IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33311         IF(IPAMDL(13).GT.0) THEN
33312           GOTO 55
33313         ELSE
33314           DDREL = DDREL/2.D0
33315           DDABS = DDABS/2.D0
33316           WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33317      &      'increasing precision of tests to',DDREL,DDABS
33318           GOTO 50
33319         ENDIF
33320       ENDIF
33321
33322       END
33323
33324 *$ CREATE PHO_ABORT.FOR
33325 *COPY PHO_ABORT
33326 CDECK  ID>, PHO_ABORT
33327       SUBROUTINE PHO_ABORT
33328 C**********************************************************************
33329 C
33330 C     top MC event generation due to fatal error,
33331 C     print all information of event generation and history
33332 C
33333 C**********************************************************************
33334       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33335       SAVE
33336
33337 C  input/output channels
33338       INTEGER LI,LO
33339       COMMON /POINOU/ LI,LO
33340 C  event debugging information
33341       INTEGER NMAXD
33342       PARAMETER (NMAXD=100)
33343       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33344      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33345       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33346      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33347 C  model switches and parameters
33348       CHARACTER*8 MDLNA
33349       INTEGER ISWMDL,IPAMDL
33350       DOUBLE PRECISION PARMDL
33351       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33352 C  standard particle data interface
33353       INTEGER NMXHEP
33354       PARAMETER (NMXHEP=4000)
33355       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33356       DOUBLE PRECISION PHEP,VHEP
33357       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33358      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33359      &                VHEP(4,NMXHEP)
33360 C  extension to standard particle data interface (PHOJET specific)
33361       INTEGER IMPART,IPHIST,ICOLOR
33362       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33363 C  color string configurations including collapsed strings and hadrons
33364       INTEGER MSTR
33365       PARAMETER (MSTR=500)
33366       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33367       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33368      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33369      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33370 C  light-cone x fractions and c.m. momenta of soft cut string ends
33371       INTEGER MAXSOF
33372       PARAMETER ( MAXSOF = 50 )
33373       INTEGER IJSI2,IJSI1
33374       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33375       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33376      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33377      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
33378 C  hard scattering data
33379       INTEGER MSCAHD
33380       PARAMETER ( MSCAHD = 50 )
33381       INTEGER LSCAHD,LSC1HD,LSIDX,
33382      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33383       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33384       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33385      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33386      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33387      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33388      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33389      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33390      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33391
33392       WRITE(LO,'(//,1X,A,/,1X,A)')
33393      &  'PHO_ABORT: program execution stopped',
33394      &  '===================================='
33395       WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33396 C
33397       CALL PHO_SETMDL(0,0,-2)
33398       CALL PHO_PREVNT(-1)
33399       CALL PHO_ACTPDF(0,-2)
33400 C  print selected parton flavours
33401       WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33402       DO 700 I=1,KSOFT
33403         WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33404  700  CONTINUE
33405       WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33406       DO 750 K=1,KHARD
33407         I = LSIDX(K)
33408         WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33409         WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33410      &    NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33411  750  CONTINUE
33412 C  print selected parton momenta
33413       WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33414       DO 300 I=1,KSOFT
33415         WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33416         WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33417  300  CONTINUE
33418       WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33419       DO 350 K=1,KHARD
33420         I = LSIDX(K)
33421         I3 = 8*I-4
33422         WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33423         WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33424  350  CONTINUE
33425
33426 C  print /POEVT1/
33427       CALL PHO_PREVNT(0)
33428
33429 C  fragmentation process
33430       IF(ISTR.GT.0) THEN
33431 C  print /POSTRG/
33432         CALL PHO_PRSTRG
33433         IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33434       ENDIF
33435
33436 C  last message
33437       WRITE(LO,'(////5X,A,///5X,A,///)')
33438      &  'PHO_ABORT: execution terminated due to fatal error',
33439      &'*** Simulating division by zero to get traceback information ***'
33440       ISTR = 100/IPAMDL(100)
33441
33442       END
33443
33444 *$ CREATE PHO_TRACE.FOR
33445 *COPY PHO_TRACE
33446 CDECK  ID>, PHO_TRACE
33447       SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33448 C**********************************************************************
33449 C
33450 C     trace program subroutines according to level,
33451 C                          original output levels will be saved
33452 C
33453 C     input:   ISTART      first event to trace
33454 C              ISWI        number of events to trace
33455 C                                0   loop call, use old values
33456 C                               -1   restore original output levels
33457 C                                1   store level and wait for event
33458 C              LEVEL       desired output level
33459 C                                0   standard output
33460 C                                3   internal rejections
33461 C                                5   cross sections, slopes etc.
33462 C                               10   parameter of subroutines and
33463 C                                    results
33464 C                               20   huge amount of debug output
33465 C                               30   maximal possible output
33466 C
33467 C**********************************************************************
33468       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33469       SAVE
33470
33471 C  input/output channels
33472       INTEGER LI,LO
33473       COMMON /POINOU/ LI,LO
33474 C  event debugging information
33475       INTEGER NMAXD
33476       PARAMETER (NMAXD=100)
33477       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33478      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33479       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33480      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33481
33482       DIMENSION IMEM(NMAXD)
33483
33484 C  protect ISWI
33485       ISW = ISWI
33486  10   CONTINUE
33487       IF(ISW.EQ.0) THEN
33488         IF(KEVENT.LT.ION) THEN
33489           RETURN
33490         ELSE IF(KEVENT.EQ.ION) THEN
33491           WRITE(LO,'(///,1X,A,///)')
33492      &      'PHO_TRACE: trace mode switched on'
33493           DO 100 I=1,NMAXD
33494             IMEM(I) = IDEB(I)
33495             IDEB(I) = MAX(ILEVEL,IMEM(I))
33496  100      CONTINUE
33497         ELSE IF(KEVENT.EQ.IOFF) THEN
33498           WRITE(LO,'(//,1X,A,///)')
33499      &      'PHO_TRACE: trace mode switched off'
33500           DO 200 I=1,NMAXD
33501             IDEB(I) = IMEM(I)
33502  200      CONTINUE
33503         ENDIF
33504       ELSE IF(ISW.EQ.-1) THEN
33505         DO 300 I=1,NMAXD
33506           IDEB(I) = IMEM(I)
33507  300    CONTINUE
33508       ELSE
33509 C  save information
33510         ION = ISTART
33511         IOFF = ISTART+ISW
33512         ILEVEL = LEVEL
33513       ENDIF
33514 C  check coincidence
33515       IF(ISW.GT.0) THEN
33516         ISW=0
33517         ILEVEL = LEVEL
33518         GOTO 10
33519       ENDIF
33520
33521       END
33522
33523 *$ CREATE PHO_PRSTRG.FOR
33524 *COPY PHO_PRSTRG
33525 CDECK  ID>, PHO_PRSTRG
33526       SUBROUTINE PHO_PRSTRG
33527 C**********************************************************************
33528 C
33529 C     print information of /POSTRG/
33530 C
33531 C**********************************************************************
33532       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33533       SAVE
33534
33535 C  input/output channels
33536       INTEGER LI,LO
33537       COMMON /POINOU/ LI,LO
33538 C  event debugging information
33539       INTEGER NMAXD
33540       PARAMETER (NMAXD=100)
33541       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33542      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33543       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33544      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33545 C  standard particle data interface
33546       INTEGER NMXHEP
33547       PARAMETER (NMXHEP=4000)
33548       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33549       DOUBLE PRECISION PHEP,VHEP
33550       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33551      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33552      &                VHEP(4,NMXHEP)
33553 C  extension to standard particle data interface (PHOJET specific)
33554       INTEGER IMPART,IPHIST,ICOLOR
33555       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33556 C  color string configurations including collapsed strings and hadrons
33557       INTEGER MSTR
33558       PARAMETER (MSTR=500)
33559       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33560       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33561      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33562      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33563
33564       WRITE(LO,'(/,1X,A,I5)')
33565      &  'PHO_PRSTRG: number of strings soft+hard:',ISTR
33566       WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33567      &  ' NOBAM  ID1  ID2  ID3  ID4     NPO1/2/3/4        MASS'
33568       WRITE(LO,'(1X,A)')
33569      &  ' ======================================================='
33570       DO 800 I=1,ISTR
33571         WRITE(LO,'(1X,9I5,1P,E11.3)')
33572      &         NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33573      &         NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33574  800  CONTINUE
33575
33576       END
33577
33578 *$ CREATE PHO_PREVNT.FOR
33579 *COPY PHO_PREVNT
33580 CDECK  ID>, PHO_PREVNT
33581       SUBROUTINE PHO_PREVNT(NPART)
33582 C**********************************************************************
33583 C
33584 C     print all information of event generation and history
33585 C
33586 C     input:        NPART  -1   minimal output: process IDs
33587 C                           0   additional output of /POEVT1/
33588 C                           1   additional output of /POSTRG/
33589 C                           2   additional output of /HEPEVT/
33590 C                               (call LULIST(1))
33591 C
33592 C**********************************************************************
33593       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33594       SAVE
33595
33596 C  input/output channels
33597       INTEGER LI,LO
33598       COMMON /POINOU/ LI,LO
33599 C  event debugging information
33600       INTEGER NMAXD
33601       PARAMETER (NMAXD=100)
33602       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33603      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33604       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33605      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33606 C  model switches and parameters
33607       CHARACTER*8 MDLNA
33608       INTEGER ISWMDL,IPAMDL
33609       DOUBLE PRECISION PARMDL
33610       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33611 C  global event kinematics and particle IDs
33612       INTEGER IFPAP,IFPAB
33613       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33614       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33615 C  general process information
33616       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33617       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33618 C  standard particle data interface
33619       INTEGER NMXHEP
33620       PARAMETER (NMXHEP=4000)
33621       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33622       DOUBLE PRECISION PHEP,VHEP
33623       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33624      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33625      &                VHEP(4,NMXHEP)
33626 C  extension to standard particle data interface (PHOJET specific)
33627       INTEGER IMPART,IPHIST,ICOLOR
33628       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33629 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
33630       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33631       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33632       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33633      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33634
33635       CHARACTER*15 PHO_PNAME
33636
33637       IF(NPART.GE.0) WRITE(LO,'(/)')
33638       WRITE(LO,'(1X,A,1PE10.3)')
33639      &  'PHO_PREVNT: c.m. energy',ECM
33640       CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33641       WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33642      &  'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33643      &  'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33644      &  KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33645      &  KHDPO
33646       WRITE(LO,'(6X,A,I4,4I3)')
33647      &  'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33648      &  IDIFR2,IDDPOM
33649
33650       IF(IPAMDL(13).GT.0) THEN
33651         WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33652         WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33653      &    ECMN,PCMN,SECM,SPCM
33654         WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33655       ENDIF
33656
33657       IF(NPART.LT.0) RETURN
33658
33659       IF(NPART.GE.1) CALL PHO_PRSTRG
33660
33661       WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33662       ICHAS  = 0
33663       IBARFS = 0
33664       IMULC  = 0
33665       IMUL   = 0
33666       WRITE(LO,'(/1X,A,A,/,1X,A,A)')
33667      &  '   NO  IST    NAME         MO-1 MO-2 DA-1 DA-2  CHA  BAR',
33668      &  '  IH1  IH2  CO1  CO2',
33669      &  '========================================================',
33670      &  '===================='
33671       DO 20 IH=1,NHEP
33672         CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
33673         BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
33674         WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
33675      &    IH,ISTHEP(IH),PHO_PNAME(IH,2),
33676      &    JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
33677      &    CH,BA,IPHIST(1,IH),IPHIST(2,IH),
33678      &    ICOLOR(1,IH),ICOLOR(2,IH)
33679         IF(ABS(ISTHEP(IH)).EQ.1) THEN
33680           ICHAS  = ICHAS  + IPHO_CHR3(IH,2)
33681           IBARFS = IBARFS + IPHO_BAR3(IH,2)
33682         ENDIF
33683         IF(ABS(ISTHEP(IH)).EQ.1) THEN
33684           IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
33685           IMUL = IMUL+1
33686         ENDIF
33687    20 CONTINUE
33688       WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
33689      &  'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
33690
33691       WRITE(LO,7)
33692       PXS    = 0.D0
33693       PYS    = 0.D0
33694       PZS    = 0.D0
33695       P0S    = 0.D0
33696       DO 30 IN=1,NHEP
33697         IF(     (ABS(PHEP(3,IN)).LT.99999.D0)
33698      &     .AND.(PHEP(4,IN).LT.99999.D0)) THEN
33699           WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33700      &      (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33701         ELSE
33702           WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33703      &      (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33704         ENDIF
33705         IF(ABS(ISTHEP(IN)).EQ.1) THEN
33706           PXS = PXS + PHEP(1,IN)
33707           PYS = PYS + PHEP(2,IN)
33708           PZS = PZS + PHEP(3,IN)
33709           P0S = P0S + PHEP(4,IN)
33710         ENDIF
33711    30 CONTINUE
33712       AMFS = P0S**2-PXS**2-PYS**2-PZS**2
33713       AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
33714       IF(P0S.LT.99999.D0) THEN
33715         WRITE(LO,10) '      sum:    ',PXS,PYS,PZS,P0S,AMFS
33716       ELSE
33717         WRITE(LO,12) '      sum:    ',PXS,PYS,PZS,P0S,AMFS
33718       ENDIF
33719       WRITE(LO,'(//)')
33720
33721     5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
33722      &  8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
33723      &  8H CHARGE ,8H BARYON ,/)
33724     6 FORMAT(7I8,2F8.3)
33725     7 FORMAT(/,2X,' NR STAT NAME        X-MOMENTA',
33726      &  ' Y-MOMENTA Z-MOMENTA  ENERGY    MASS     PT',/,
33727      &         2X,'-------------------------------',
33728      &  '--------------------------------------------')
33729     8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
33730     9 FORMAT(I10,14X,5F10.3)
33731    10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
33732    11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
33733    12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
33734
33735       IF(NPART.GE.2) CALL PYLIST(1)
33736
33737       END
33738
33739 *$ CREATE PHO_LTRHEP.FOR
33740 *COPY PHO_LTRHEP
33741 CDECK  ID>, PHO_LTRHEP
33742       SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
33743 C*******************************************************************
33744 C
33745 C     Lorentz transformation of entries I1 to I2 in /POEVT1/
33746 C
33747 C********************************************************************
33748       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33749       SAVE
33750
33751       PARAMETER ( DIFF = 0.001D0,
33752      &            EPS  = 1.D-5 )
33753
33754 C  input/output channels
33755       INTEGER LI,LO
33756       COMMON /POINOU/ LI,LO
33757 C  event debugging information
33758       INTEGER NMAXD
33759       PARAMETER (NMAXD=100)
33760       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33761      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33762       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33763      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33764 C  standard particle data interface
33765       INTEGER NMXHEP
33766       PARAMETER (NMXHEP=4000)
33767       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33768       DOUBLE PRECISION PHEP,VHEP
33769       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33770      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33771      &                VHEP(4,NMXHEP)
33772 C  extension to standard particle data interface (PHOJET specific)
33773       INTEGER IMPART,IPHIST,ICOLOR
33774       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33775
33776       DO 100 I=I1,MIN(I2,NHEP)
33777         IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
33778           CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33779      &      XX,YY,ZZ)
33780           EE=PHEP(4,I)
33781           CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33782      &      PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
33783         ELSE IF(ISTHEP(I).EQ.20) THEN
33784           EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
33785           CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33786      &      XX,YY,ZZ)
33787           CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33788      &      PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
33789         ENDIF
33790  100  CONTINUE
33791
33792 C  debug precision
33793       IF(IDEB(70).LT.1) RETURN
33794       DO 200 I=I1,MIN(NHEP,I2)
33795         IF(ABS(ISTHEP(I)).GT.10) GOTO 190
33796         PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
33797         PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
33798         IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
33799           WRITE(LO,'(1X,A,I5,2E13.4)')
33800      &      'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
33801         ENDIF
33802  190    CONTINUE
33803  200  CONTINUE
33804
33805       END
33806
33807 *$ CREATE PHO_PECMS.FOR
33808 *COPY PHO_PECMS
33809 CDECK  ID>, PHO_PECMS
33810       SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
33811 C*******************************************************************
33812 C
33813 C     calculation of cms momentum and energy of massive particle
33814 C     (ID=  1 using PMASS1,  2 using PMASS2)
33815 C
33816 C     output:  PP    cms momentum
33817 C              EE    energy in CMS of particle ID
33818 C
33819 C********************************************************************
33820       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33821       SAVE
33822
33823 C  input/output channels
33824       INTEGER LI,LO
33825       COMMON /POINOU/ LI,LO
33826 C  event debugging information
33827       INTEGER NMAXD
33828       PARAMETER (NMAXD=100)
33829       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33830      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33831       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33832      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33833 C  some constants
33834       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
33835       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
33836      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
33837
33838       S=ECM**2
33839       PM1 = SIGN(PMASS1**2,PMASS1)
33840       PM2 = SIGN(PMASS2**2,PMASS2)
33841       PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
33842      &          + PM1**2 + PM2**2)/(2.D0*ECM)
33843
33844       IF(ID.EQ.1) THEN
33845         EE = SQRT( PM1 + PP**2 )
33846       ELSE IF(ID.EQ.2) THEN
33847         EE = SQRT( PM2 + PP**2 )
33848       ELSE
33849         WRITE(LO,'(/1X,A,I3,/)')
33850      &    'PHO_PECMS:ERROR: invalid ID number:',ID
33851         EE = PP
33852       ENDIF
33853
33854       END
33855
33856 *$ CREATE PHO_FRAINI.FOR
33857 *COPY PHO_FRAINI
33858 CDECK  ID>, PHO_FRAINI
33859       SUBROUTINE PHO_FRAINI(IDEFAU)
33860 C***********************************************************************
33861 C
33862 C     initialization of fragmentation packages
33863 C      (currently LUND JETSET)
33864 C
33865 C     initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
33866 C                      changed to work in PHOJET   (R.E. 1/94)
33867 C
33868 C     input:  IDEFAU    0  no hadronization at all
33869 C                       1  do not touch any parameter of JETSET
33870 C                       2  default parameters kept, decay length 10mm to
33871 C                          define stable particles
33872 C                       3  load tuned parameters for JETSET 7.3
33873 C             neg. value:  prevent strange/charm hadrons from decaying
33874 C
33875 C***********************************************************************
33876       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33877       SAVE
33878
33879       PARAMETER (EPS=1.D-10)
33880
33881 C  input/output channels
33882       INTEGER LI,LO
33883       COMMON /POINOU/ LI,LO
33884       INTEGER N,NPAD,K
33885       DOUBLE PRECISION P,V
33886       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33887       INTEGER MSTU,MSTJ
33888       DOUBLE PRECISION PARU,PARJ
33889       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33890       INTEGER KCHG
33891       DOUBLE PRECISION  PMAS,PARF,VCKM
33892       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33893       INTEGER MDCY,MDME,KFDP
33894       DOUBLE PRECISION  BRAT
33895       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33896
33897       INTEGER PYCOMP
33898
33899       IDEFAB = ABS(IDEFAU)
33900
33901       IF(IDEFAB.EQ.0) THEN
33902         WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
33903         RETURN
33904       ENDIF
33905 C  defaults
33906       DEF2  = PARJ(2)
33907       IDEF12 = MSTJ(12)
33908       DEF19 = PARJ(19)
33909       DEF41 = PARJ(41)
33910       DEF42 = PARJ(42)
33911       DEF21 = PARJ(21)
33912
33913 C  declare stable particles
33914 c     IF(IDEFAB.GE.2) MSTJ(22) = 2
33915
33916 C  load optimized parameters
33917       IF(IDEFAB.GE.3) THEN
33918 *       PARJ(19)=0.19
33919 C  Lund a-parameter
33920 C  (default=0.3)
33921         PARJ(41)=0.3
33922 C  Lund b-parameter
33923 C  (default=1.0)
33924         PARJ(42)=1.0
33925 C  Lund sigma parameter in pt distribution
33926 C  (default=0.36)
33927         PARJ(21)=0.36
33928       ENDIF
33929 C
33930 C  prevent particles decaying
33931       IF(IDEFAU.LT.0) THEN
33932 C                 K0S
33933         KC=PYCOMP(310)
33934         MDCY(KC,1)=0
33935 C                 PI0
33936         KC=PYCOMP(111)
33937         MDCY(KC,1)=0
33938 C                 LAMBDA
33939         KC=PYCOMP(3122)
33940         MDCY(KC,1)=0
33941 C                 ALAMBDA
33942         KC=PYCOMP(-3122)
33943         MDCY(KC,1)=0
33944 C                 SIG+
33945         KC=PYCOMP(3222)
33946         MDCY(KC,1)=0
33947 C                 ASIG+
33948         KC=PYCOMP(-3222)
33949         MDCY(KC,1)=0
33950 C                 SIG-
33951         KC=PYCOMP(3112)
33952         MDCY(KC,1)=0
33953 C                 ASIG-
33954         KC=PYCOMP(-3112)
33955         MDCY(KC,1)=0
33956 C                 SIG0
33957         KC=PYCOMP(3212)
33958         MDCY(KC,1)=0
33959 C                 ASIG0
33960         KC=PYCOMP(-3212)
33961         MDCY(KC,1)=0
33962 C                 TET0
33963         KC=PYCOMP(3322)
33964         MDCY(KC,1)=0
33965 C                 ATET0
33966         KC=PYCOMP(-3322)
33967         MDCY(KC,1)=0
33968 C                 TET-
33969         KC=PYCOMP(3312)
33970         MDCY(KC,1)=0
33971 C                 ATET-
33972         KC=PYCOMP(-3312)
33973         MDCY(KC,1)=0
33974 C                 OMEGA-
33975         KC=PYCOMP(3334)
33976         MDCY(KC,1)=0
33977 C                 AOMEGA-
33978         KC=PYCOMP(-3334)
33979         MDCY(KC,1)=0
33980 C                 D+
33981         KC=PYCOMP(411)
33982         MDCY(KC,1)=0
33983 C                 D-
33984         KC=PYCOMP(-411)
33985         MDCY(KC,1)=0
33986 C                 D0
33987         KC=PYCOMP(421)
33988         MDCY(KC,1)=0
33989 C                 A-D0
33990         KC=PYCOMP(-421)
33991         MDCY(KC,1)=0
33992 C                 DS+
33993         KC=PYCOMP(431)
33994         MDCY(KC,1)=0
33995 C                 A-DS+
33996         KC=PYCOMP(-431)
33997         MDCY(KC,1)=0
33998 C                ETAC
33999         KC=PYCOMP(441)
34000         MDCY(KC,1)=0
34001 C                LAMBDAC+
34002         KC=PYCOMP(4122)
34003         MDCY(KC,1)=0
34004 C                A-LAMBDAC+
34005         KC=PYCOMP(-4122)
34006         MDCY(KC,1)=0
34007 C                SIGMAC++
34008         KC=PYCOMP(4222)
34009         MDCY(KC,1)=0
34010 C                SIGMAC+
34011         KC=PYCOMP(4212)
34012         MDCY(KC,1)=0
34013 C                SIGMAC0
34014         KC=PYCOMP(4112)
34015         MDCY(KC,1)=0
34016 C                A-SIGMAC++
34017         KC=PYCOMP(-4222)
34018         MDCY(KC,1)=0
34019 C                A-SIGMAC+
34020         KC=PYCOMP(-4212)
34021         MDCY(KC,1)=0
34022 C                A-SIGMAC0
34023         KC=PYCOMP(-4112)
34024         MDCY(KC,1)=0
34025 C                KSIC+
34026         KC=PYCOMP(4232)
34027         MDCY(KC,1)=0
34028 C                KSIC0
34029         KC=PYCOMP(4132)
34030         MDCY(KC,1)=0
34031 C                A-KSIC+
34032         KC=PYCOMP(-4232)
34033         MDCY(KC,1)=0
34034 C                A-KSIC0
34035         KC=PYCOMP(-4132)
34036         MDCY(KC,1)=0
34037       ENDIF
34038
34039       WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34040      &  DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34041  2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34042      &        ' --------------------------------------------------',/,
34043      & 5X,'parameter description               default / current',/,
34044      & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34045      & 5X,'MSTJ(12) popcorn                 : ',2I7,/,
34046      & 5X,'PARJ(19) popcorn                 : ',2F7.3,/,
34047      & 5X,'PARJ(41) Lund a                  : ',2F7.3,/,
34048      & 5X,'PARJ(42) Lund b                  : ',2F7.3,/,
34049      & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34050
34051       END
34052
34053 *$ CREATE PHO_SETPAR.FOR
34054 *COPY PHO_SETPAR
34055 CDECK  ID>, PHO_SETPAR
34056       SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34057 C**********************************************************************
34058 C
34059 C     assign a particle to either side 1 or 2
34060 C     (including special treatment for remnants)
34061 C
34062 C     input:    Iside      1,2  side selected for the particle
34063 C                          -2   output of current settings
34064 C               IDpdg      PDG number
34065 C               IDcpc      CPC number
34066 C                          0     CPC determination in subroutine
34067 C                          -1    special particle remnant, IDPDG
34068 C                                is the particle number the remnant
34069 C                                corresponds to (see /POHDFL/)
34070 C
34071 C**********************************************************************
34072       IMPLICIT NONE
34073       SAVE
34074
34075       integer Iside,IDpdg,IDcpc
34076       double precision Pvir
34077
34078 C  input/output channels
34079       INTEGER LI,LO
34080       COMMON /POINOU/ LI,LO
34081 C  event debugging information
34082       INTEGER NMAXD
34083       PARAMETER (NMAXD=100)
34084       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34085      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34086       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34087      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34088 C  global event kinematics and particle IDs
34089       INTEGER IFPAP,IFPAB
34090       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34091       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34092 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
34093       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34094       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34095       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34096      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34097 C  particle ID translation table
34098       integer         ID_pdg_list,ID_list,ID_pdg_max
34099       character*12    name_list
34100       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34101      &                ID_pdg_max
34102 C  general particle data
34103       double precision xm_list,tau_list,gam_list,
34104      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34105      &  xm_bb82_list,xm_bb102_list
34106       integer          ich3_list,iba3_list,iq_list,
34107      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
34108       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34109      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
34110      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34111      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34112      &  ich3_list(300),iba3_list(300),iq_list(3,300),
34113      &  id_psm_list(6,6),id_vem_list(6,6),
34114      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
34115 C  particle decay data
34116       double precision wg_sec_list
34117       integer          idec_list,isec_list
34118       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34119      &  isec_list(3,500)
34120
34121 C  external functions
34122       integer ipho_pdg2id,ipho_chr3,ipho_bar3
34123       double precision pho_pmass
34124
34125 C  local variables
34126       integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34127
34128       IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34129         IDcpcN = IDcpc
34130 C  remnant?
34131         IF(IDcpc.EQ.-1) THEN
34132           IF(Iside.EQ.1) THEN
34133             IDpdgR = 81
34134           ELSE
34135             IDpdgR = 82
34136           ENDIF
34137           IDcpcR = ipho_pdg2id(IDpdgR)
34138           IDEQB(Iside) = ipho_pdg2id(IDpdg)
34139           IDEQP(Iside) = IDpdg
34140 C  copy particle properties
34141           IDB = abs(IDEQB(Iside))
34142           xm_list(IDcpcR)  = xm_list(IDB)
34143           tau_list(IDcpcR) = tau_list(IDB)
34144           gam_list(IDcpcR) = gam_list(IDB)
34145           IF(IHFLS(Iside).EQ.1) THEN
34146             ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34147             iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34148           ELSE
34149             ich3_list(IDcpcR) = 0
34150             iba3_list(IDcpcR) = 0
34151           ENDIF
34152 C  quark content
34153           IFL1 = IHFLD(Iside,1)
34154           IFL2 = IHFLD(Iside,2)
34155           IFL3 = 0
34156           IF(IHFLS(Iside).EQ.1) THEN
34157             IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34158               IFL1 = IHFLD(Iside,1)/1000
34159               IFL2 = MOD(IHFLD(Iside,1)/100,10)
34160               IFL3 = IHFLD(Iside,2)
34161             ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34162               IFL1 = IHFLD(Iside,1)
34163               IFL2 = IHFLD(Iside,2)/1000
34164               IFL3 = MOD(IHFLD(Iside,2)/100,10)
34165             ENDIF
34166           ENDIF
34167           iq_list(1,IDcpcR) = IFL1
34168           iq_list(2,IDcpcR) = IFL2
34169           iq_list(3,IDcpcR) = IFL3
34170
34171           IDcpcN = IDcpcR
34172           IDPDGN = IDPDGR
34173
34174           IF(IDEB(87).GE.5) THEN
34175             WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34176      &        'pho_setpar: remnant assignment side',Iside,
34177      &        'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34178           ENDIF
34179         ELSE IF(IDcpc.EQ.0) THEN
34180 C  ordinary hadron
34181           IHFLS(Iside) = 1
34182           IHFLD(Iside,1) = 0
34183           IHFLD(Iside,2) = 0
34184           IDcpcN = ipho_pdg2id(IDpdg)
34185           IDpdgN = IDpdg
34186         ENDIF
34187
34188 C initialize /POGCMS/
34189         IFPAP(Iside) = IDpdgN
34190         IFPAB(Iside) = IDcpcN
34191         PMASS(Iside) = pho_pmass(IDcpcN,0)
34192         IF(IFPAP(Iside).EQ.22) THEN
34193           PVIRT(Iside) = ABS(PVIR)
34194         ELSE
34195           PVIRT(Iside) = 0.D0
34196         ENDIF
34197
34198       ELSE IF(Iside.EQ.-2) THEN
34199 C  output of current settings
34200         DO 100 I=1,2
34201           WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34202      &      'PHO_SETPAR: side',
34203      &      I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34204      &      PVIRT(I)
34205           IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34206             WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34207      &        'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34208      &        IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34209           ENDIF
34210  100    CONTINUE
34211       ELSE
34212         WRITE(LO,'(/1X,A,I8)')
34213      &    'pho_setpar: invalid argument (Iside)',Iside
34214       ENDIF
34215
34216       END
34217
34218 *$ CREATE PHO_XLAM.FOR
34219 *COPY PHO_XLAM
34220 CDECK  ID>, PHO_XLAM
34221       DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34222 C**********************************************************************
34223 C
34224 C     auxiliary function for two/three particle decay mode
34225 C     (standard LAMBDA**(1/2) function)
34226 C
34227 C**********************************************************************
34228       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34229       SAVE
34230 C
34231       YZ=Y-Z
34232       XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34233       IF(XLAM.LT.0.D0) XLAM=-XLAM
34234       PHO_XLAM=SQRT(XLAM)
34235       END
34236
34237 *$ CREATE PHO_BESSJ0.FOR
34238 *COPY PHO_BESSJ0
34239 CDECK  ID>, PHO_BESSJ0
34240       DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34241 C**********************************************************************
34242 C
34243 C     CERN (KERN) LIB function C312
34244 C
34245 C     modified by R. Engel (03/02/93)
34246 C
34247 C**********************************************************************
34248       DOUBLE PRECISION DX
34249       DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34250       DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34251       SAVE
34252
34253       DATA EIGHT /8.0D0/
34254       DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34255
34256       DATA C1( 0) /+0.15772 79714 7489D0/
34257       DATA C1( 1) /-0.00872 34423 5285D0/
34258       DATA C1( 2) /+0.26517 86132 0334D0/
34259       DATA C1( 3) /-0.37009 49938 7265D0/
34260       DATA C1( 4) /+0.15806 71023 3210D0/
34261       DATA C1( 5) /-0.03489 37694 1141D0/
34262       DATA C1( 6) /+0.00481 91800 6947D0/
34263       DATA C1( 7) /-0.00046 06261 6621D0/
34264       DATA C1( 8) /+0.00003 24603 2882D0/
34265       DATA C1( 9) /-0.00000 17619 4691D0/
34266       DATA C1(10) /+0.00000 00760 8164D0/
34267       DATA C1(11) /-0.00000 00026 7925D0/
34268       DATA C1(12) /+0.00000 00000 7849D0/
34269       DATA C1(13) /-0.00000 00000 0194D0/
34270       DATA C1(14) /+0.00000 00000 0004D0/
34271
34272       DATA C2( 0) /+0.99946 03493 4752D0/
34273       DATA C2( 1) /-0.00053 65220 4681D0/
34274       DATA C2( 2) /+0.00000 30751 8479D0/
34275       DATA C2( 3) /-0.00000 00517 0595D0/
34276       DATA C2( 4) /+0.00000 00016 3065D0/
34277       DATA C2( 5) /-0.00000 00000 7864D0/
34278       DATA C2( 6) /+0.00000 00000 0517D0/
34279       DATA C2( 7) /-0.00000 00000 0043D0/
34280       DATA C2( 8) /+0.00000 00000 0004D0/
34281       DATA C2( 9) /-0.00000 00000 0001D0/
34282
34283       DATA C3( 0) /-0.01555 58546 05337D0/
34284       DATA C3( 1) /+0.00006 83851 99426D0/
34285       DATA C3( 2) /-0.00000 07414 49841D0/
34286       DATA C3( 3) /+0.00000 00179 72457D0/
34287       DATA C3( 4) /-0.00000 00007 27192D0/
34288       DATA C3( 5) /+0.00000 00000 42201D0/
34289       DATA C3( 6) /-0.00000 00000 03207D0/
34290       DATA C3( 7) /+0.00000 00000 00301D0/
34291       DATA C3( 8) /-0.00000 00000 00033D0/
34292       DATA C3( 9) /+0.00000 00000 00004D0/
34293       DATA C3(10) /-0.00000 00000 00001D0/
34294
34295       X=DX
34296       V=ABS(X)
34297       IF(V .LT. EIGHT) THEN
34298        Y=V/EIGHT
34299        H=2.D0*Y**2-1.D0
34300        ALFA=-2.D0*H
34301        B1=0.D0
34302        B2=0.D0
34303        DO 1 I = 14,0,-1
34304        B0=C1(I)-ALFA*B1-B2
34305        B2=B1
34306     1  B1=B0
34307        B1=B0-H*B2
34308       ELSE
34309        R=1.D0/V
34310        Y=EIGHT*R
34311        H=2.D0*Y**2-1.D0
34312        ALFA=-2.D0*H
34313        B1=0.D0
34314        B2=0.D0
34315        DO 2 I = 9,0,-1
34316        B0=C2(I)-ALFA*B1-B2
34317        B2=B1
34318     2  B1=B0
34319        P=B0-H*B2
34320        B1=0.D0
34321        B2=0.D0
34322        DO 3 I = 10,0,-1
34323        B0=C3(I)-ALFA*B1-B2
34324        B2=B1
34325     3  B1=B0
34326        Q=Y*(B0-H*B2)
34327        B0=V-PI2
34328        B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34329       ENDIF
34330       PHO_BESSJ0=B1
34331       RETURN
34332       END
34333
34334 *$ CREATE PHO_BESSI0.FOR
34335 *COPY PHO_BESSI0
34336 CDECK  ID>, PHO_BESSI0
34337       DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34338 C**********************************************************************
34339 C
34340 C      Bessel Function I0
34341 C
34342 C**********************************************************************
34343       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34344       SAVE
34345
34346       AX = ABS(X)
34347       IF (AX .LT. 3.75D0) THEN
34348         Y = (X/3.75D0)**2
34349         PHO_BESSI0 =
34350      &    1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34351      &    +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34352       ELSE
34353         Y = 3.75D0/AX
34354         PHO_BESSI0 =
34355      &    (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34356      &    +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34357      &    +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34358      &    +Y*0.392377D-2))))))))
34359       ENDIF
34360
34361       END
34362
34363 *$ CREATE PHO_BESSI1.FOR
34364 *COPY PHO_BESSI1
34365 CDECK  ID>, PHO_BESSI1
34366       DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34367 C**********************************************************************
34368 C
34369 C      Bessel Function I1
34370 C
34371 C**********************************************************************
34372       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34373       SAVE
34374
34375       AX = ABS(X)
34376
34377       IF (AX .LT. 3.75D0) THEN
34378         Y = (X/3.75D0)**2
34379         BESLI1 =
34380      &    AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34381      &    +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34382       ELSE
34383         Y = 3.75D0/AX
34384         BESLI1 =
34385      &    0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34386      &    -Y*0.420059D-2))
34387         BESLI1 =
34388      &    0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34389      &    +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34390         BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34391       ENDIF
34392       IF (X .LT. 0.D0) BESLI1 = -BESLI1
34393
34394       PHO_BESSI1 = BESLI1
34395
34396       END
34397
34398 *$ CREATE PHO_BESSK0.FOR
34399 *COPY PHO_BESSK0
34400 CDECK  ID>, PHO_BESSK0
34401       DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34402 C**********************************************************************
34403 C
34404 C      Modified Bessel Function K0
34405 C
34406 C**********************************************************************
34407       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34408       SAVE
34409
34410       IF (X .LT. 2.D0) THEN
34411         Y = X**2/4.D0
34412         PHO_BESSK0 =
34413      &    (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34414      &    +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34415      &    +Y*(0.10750D-3+Y*0.740D-5))))))
34416       ELSE
34417         Y = 2.D0/X
34418         PHO_BESSK0 =
34419      &    (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34420      &    +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34421      &    +Y*(-0.251540D-2+Y*0.53208D-3))))))
34422       ENDIF
34423
34424       END
34425
34426 *$ CREATE PHO_BESSK1.FOR
34427 *COPY PHO_BESSK1
34428 CDECK  ID>, PHO_BESSK1
34429       DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34430 C**********************************************************************
34431 C
34432 C      Modified Bessel Function K1
34433 C
34434 C**********************************************************************
34435       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34436       SAVE
34437
34438       IF (X .LT. 2.D0) THEN
34439         Y = X**2/4.D0
34440         PHO_BESSK1 =
34441      &    (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34442      &    +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34443      &    +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34444       ELSE
34445         Y=2.D0/X
34446         PHO_BESSK1 =
34447      &    (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34448      &    +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34449      &    +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34450       ENDIF
34451
34452       END
34453
34454 *$ CREATE PHO_GAUSET.FOR
34455 *COPY PHO_GAUSET
34456 CDECK  ID>, PHO_GAUSET
34457       SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34458 C********************************************************************
34459 C
34460 C     N-point gauss zeros and weights for the interval (AX,BX) are
34461 C           stored in  arrays Z and W respectively.
34462 C
34463 C*********************************************************************
34464       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34465       SAVE
34466
34467       COMMON /POGDAT/A(273),X(273),KTAB(96)
34468       DIMENSION Z(NX),W(NX)
34469
34470       ALPHA=0.5*(BX+AX)
34471       BETA=0.5*(BX-AX)
34472       N=NX
34473
34474 C  the N=1 case:
34475       IF(N.NE.1) GO TO 1
34476       Z(1)=ALPHA
34477       W(1)=BX-AX
34478       RETURN
34479
34480 C  the Gauss cases:
34481     1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34482       IF(N.EQ.20) GO TO 2
34483       IF(N.EQ.24) GO TO 2
34484       IF(N.EQ.32) GO TO 2
34485       IF(N.EQ.40) GO TO 2
34486       IF(N.EQ.48) GO TO 2
34487       IF(N.EQ.64) GO TO 2
34488       IF(N.EQ.80) GO TO 2
34489       IF(N.EQ.96) GO TO 2
34490
34491 C  the extended Gauss cases:
34492       IF((N/96)*96.EQ.N) GO TO 3
34493
34494 C  jump to center of intervall intrgration:
34495       GO TO 100
34496
34497 C  get Gauss point array
34498
34499     2 CALL PHO_GAUDAT
34500 C  extract real points
34501       K=KTAB(N)
34502       M=N/2
34503       DO 21 J=1,M
34504 C       extract values from big array
34505         JTAB=K-1+J
34506         WTEMP=BETA*A(JTAB)
34507         DELTA=BETA*X(JTAB)
34508 C       store them backward
34509         Z(J)=ALPHA-DELTA
34510         W(J)=WTEMP
34511 C       store them forward
34512         JP=N+1-J
34513         Z(JP)=ALPHA+DELTA
34514         W(JP)=WTEMP
34515    21 CONTINUE
34516 C     store central point (odd N)
34517       IF((N-M-M).EQ.0) RETURN
34518       Z(M+1)=ALPHA
34519       JMID=K+M
34520       W(M+1)=BETA*A(JMID)
34521       RETURN
34522
34523 C  get ND96 times chained 96 Gauss point array
34524
34525     3 CALL PHO_GAUDAT
34526 C  print out message
34527 C     -extract real points
34528       K=KTAB(96)
34529       ND96=N/96
34530       DO 31 J=1,48
34531 C       extract values from big array
34532         JTAB=K-1+J
34533         WTEMP=BETA*A(JTAB)
34534         DELTA=BETA*X(JTAB)
34535         WTeMP=WTEMP/ND96
34536         DeLTA=DELTA/ND96
34537         DO 32 JD96=0,ND96-1
34538           ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34539 C         store them backward
34540           Z(J+JD96*96)=ZCNTR-DELTA
34541           W(J+JD96*96)=WTEMP
34542 C         store them forward
34543           JP=96+1-J
34544           Z(JP+JD96*96)=ZCNTR+DELTA
34545           W(JP+JD96*96)=WTEMP
34546    32   CONTINUE
34547    31 CONTINUE
34548       RETURN
34549
34550 C  the center of intervall cases:
34551   100 CONTINUE
34552 C  put in constant weight and equally spaced central points
34553       N=IABS(N)
34554       DO 111 IN=1,N
34555         WIN=(BX-AX)/FLOAT(N)
34556         Z(IN)=AX  + (FLOAT(IN)-.5)*WIN
34557   111 W(IN)=WIN
34558
34559       END
34560
34561 *$ CREATE PHO_GAUDAT.FOR
34562 *COPY PHO_GAUDAT
34563 CDECK  ID>, PHO_GAUDAT
34564       SUBROUTINE PHO_GAUDAT
34565 C*********************************************************************
34566 C
34567 C     store big arrays needed for Gauss integral, CERNLIB D106BD
34568 C     (arrays A,X,ITAB copied on B,Y,LTAB)
34569 C
34570 C*********************************************************************
34571       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34572
34573       SAVE
34574       COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34575       DIMENSION       A(273),X(273),KTAB(96)
34576
34577 C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34578       DATA KTAB(2)/1/
34579       DATA KTAB(3)/2/
34580       DATA KTAB(4)/4/
34581       DATA KTAB(5)/6/
34582       DATA KTAB(6)/9/
34583       DATA KTAB(7)/12/
34584       DATA KTAB(8)/16/
34585       DATA KTAB(9)/20/
34586       DATA KTAB(10)/25/
34587       DATA KTAB(11)/30/
34588       DATA KTAB(12)/36/
34589       DATA KTAB(13)/42/
34590       DATA KTAB(14)/49/
34591       DATA KTAB(15)/56/
34592       DATA KTAB(16)/64/
34593       DATA KTAB(20)/72/
34594       DATA KTAB(24)/82/
34595       DATA KTAB(28)/82/
34596       DATA KTAB(32)/94/
34597       DATA KTAB(36)/94/
34598       DATA KTAB(40)/110/
34599       DATA KTAB(44)/110/
34600       DATA KTAB(48)/130/
34601       DATA KTAB(52)/130/
34602       DATA KTAB(56)/130/
34603       DATA KTAB(60)/130/
34604       DATA KTAB(64)/154/
34605       DATA KTAB(68)/154/
34606       DATA KTAB(72)/154/
34607       DATA KTAB(76)/154/
34608       DATA KTAB(80)/186/
34609       DATA KTAB(84)/186/
34610       DATA KTAB(88)/186/
34611       DATA KTAB(92)/186/
34612       DATA KTAB(96)/226/
34613 C
34614 C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
34615 C
34616 C-----N=2
34617       DATA X(1)/0.577350269189626D0  /, A(1)/1.000000000000000D0  /
34618 C-----N=3
34619       DATA X(2)/0.774596669241483D0  /, A(2)/0.555555555555556D0  /
34620       DATA X(3)/0.000000000000000D0  /, A(3)/0.888888888888889D0  /
34621 C-----N=4
34622       DATA X(4)/0.861136311594053D0  /, A(4)/0.347854845137454D0  /
34623       DATA X(5)/0.339981043584856D0  /, A(5)/0.652145154862546D0  /
34624 C-----N=5
34625       DATA X(6)/0.906179845938664D0  /, A(6)/0.236926885056189D0  /
34626       DATA X(7)/0.538469310105683D0  /, A(7)/0.478628670499366D0  /
34627       DATA X(8)/0.000000000000000D0  /, A(8)/0.568888888888889D0  /
34628 C-----N=6
34629       DATA X(9)/0.932469514203152D0  /, A(9)/0.171324492379170D0  /
34630       DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
34631       DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
34632 C-----N=7
34633       DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
34634       DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
34635       DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
34636       DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
34637 C-----N=8
34638       DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
34639       DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
34640       DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
34641       DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
34642 C-----N=9
34643       DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
34644       DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
34645       DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
34646       DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
34647       DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
34648 C-----N=10
34649       DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
34650       DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
34651       DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
34652       DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
34653       DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
34654 C-----N=11
34655       DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
34656       DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
34657       DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
34658       DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
34659       DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
34660       DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
34661 C-----N=12
34662       DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
34663       DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
34664       DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
34665       DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
34666       DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
34667       DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
34668 C-----N=13
34669       DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
34670       DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
34671       DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
34672       DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
34673       DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
34674       DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
34675       DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
34676 C-----N=14
34677       DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
34678       DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
34679       DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
34680       DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
34681       DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
34682       DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
34683       DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
34684 C-----N=15
34685       DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
34686       DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
34687       DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
34688       DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
34689       DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
34690       DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
34691       DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
34692       DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
34693 C-----N=16
34694       DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
34695       DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
34696       DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
34697       DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
34698       DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
34699       DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
34700       DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
34701       DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
34702 C-----N=20
34703       DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
34704       DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
34705       DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
34706       DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
34707       DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
34708       DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
34709       DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
34710       DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
34711       DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
34712       DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
34713 C-----N=24
34714       DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
34715       DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
34716       DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
34717       DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
34718       DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
34719       DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
34720       DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
34721       DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
34722       DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
34723       DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
34724       DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
34725       DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
34726 C-----N=32
34727       DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
34728       DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
34729       DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
34730       DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
34731       DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
34732       DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
34733       DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
34734       DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
34735       DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
34736       DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
34737       DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
34738       DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
34739       DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
34740       DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
34741       DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
34742       DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
34743 C-----N=40
34744       DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
34745       DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
34746       DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
34747       DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
34748       DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
34749       DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
34750       DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
34751       DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
34752       DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
34753       DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
34754       DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
34755       DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
34756       DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
34757       DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
34758       DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
34759       DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
34760       DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
34761       DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
34762       DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
34763       DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
34764 C-----N=48
34765       DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
34766       DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
34767       DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
34768       DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
34769       DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
34770       DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
34771       DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
34772       DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
34773       DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
34774       DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
34775       DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
34776       DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
34777       DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
34778       DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
34779       DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
34780       DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
34781       DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
34782       DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
34783       DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
34784       DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
34785       DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
34786       DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
34787       DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
34788       DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
34789 C-----N=64
34790       DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
34791       DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
34792       DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
34793       DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
34794       DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
34795       DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
34796       DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
34797       DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
34798       DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
34799       DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
34800       DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
34801       DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
34802       DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
34803       DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
34804       DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
34805       DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
34806       DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
34807       DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
34808       DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
34809       DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
34810       DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
34811       DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
34812       DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
34813       DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
34814       DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
34815       DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
34816       DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
34817       DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
34818       DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
34819       DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
34820       DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
34821       DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
34822 C-----N=80
34823       DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
34824       DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
34825       DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
34826       DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
34827       DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
34828       DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
34829       DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
34830       DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
34831       DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
34832       DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
34833       DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
34834       DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
34835       DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
34836       DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
34837       DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
34838       DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
34839       DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
34840       DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
34841       DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
34842       DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
34843       DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
34844       DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
34845       DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
34846       DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
34847       DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
34848       DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
34849       DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
34850       DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
34851       DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
34852       DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
34853       DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
34854       DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
34855       DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
34856       DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
34857       DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
34858       DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
34859       DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
34860       DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
34861       DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
34862       DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
34863 C-----N=96
34864       DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
34865       DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
34866       DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
34867       DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
34868       DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
34869       DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
34870       DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
34871       DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
34872       DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
34873       DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
34874       DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
34875       DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
34876       DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
34877       DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
34878       DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
34879       DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
34880       DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
34881       DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
34882       DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
34883       DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
34884       DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
34885       DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
34886       DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
34887       DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
34888       DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
34889       DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
34890       DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
34891       DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
34892       DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
34893       DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
34894       DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
34895       DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
34896       DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
34897       DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
34898       DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
34899       DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
34900       DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
34901       DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
34902       DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
34903       DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
34904       DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
34905       DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
34906       DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
34907       DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
34908       DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
34909       DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
34910       DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
34911       DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
34912       DATA IBD/0/
34913       IF(IBD.NE.0) RETURN
34914       IBD=1
34915       DO 10 I=1,273
34916         B(I) = A(I)
34917         Y(I) = X(I)
34918  10   CONTINUE
34919       DO 20 I=1,96
34920         LTAB(I) = KTAB(I)
34921  20   CONTINUE
34922       END
34923
34924 *$ CREATE PHO_DZEROX.FOR
34925 *COPY PHO_DZEROX
34926 CDECK  ID>, PHO_DZEROX
34927       DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
34928 C**********************************************************************
34929 C
34930 C     Based on
34931 C
34932 C        J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
34933 C        Guaranteed Convergence for Finding a Zero of a Function,
34934 C        ACM Trans. Math. Software 1 (1975) 330-345.
34935 C
34936 C        (MODE = 1: Algorithm M;    MODE = 2: Algorithm R)
34937 C
34938 C        CERNLIB C200
34939 C
34940 C***********************************************************************
34941       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34942       SAVE
34943
34944 C  input/output channels
34945       INTEGER LI,LO
34946       COMMON /POINOU/ LI,LO
34947
34948       CHARACTER NAME*(*)
34949       PARAMETER (NAME = 'PHO_DZEROX')
34950       LOGICAL LMT
34951       DIMENSION IM1(2),IM2(2),LMT(2)
34952       EXTERNAL F
34953
34954       PARAMETER (Z1 = 1, HALF = Z1/2)
34955
34956       DATA IM1 /2,3/, IM2 /-1,3/
34957
34958       IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
34959        C=-2D+10
34960        WRITE(LO,100) NAME,MODE
34961        GO TO 99
34962       ENDIF
34963       FA=F(B0)
34964       FB=F(A0)
34965       IF(FA*FB .GT. 0) THEN
34966        C=-3D+10
34967        WRITE(LO,101) NAME
34968        GO TO 99
34969       ENDIF
34970       ATL=ABS(EPS)
34971       B=A0
34972       A=B0
34973       LMT(2)=.TRUE.
34974       MF=2
34975     1 C=A
34976       FC=FA
34977     2 IE=0
34978     3 IF(ABS(FC) .LT. ABS(FB)) THEN
34979        IF(C .NE. A) THEN
34980         D=A
34981         FD=FA
34982        END IF
34983        A=B
34984        B=C
34985        C=A
34986        FA=FB
34987        FB=FC
34988        FC=FA
34989       END IF
34990       TOL=ATL*(1+ABS(C))
34991       H=HALF*(C+B)
34992       HB=H-B
34993       IF(ABS(HB) .GT. TOL) THEN
34994        IF(IE .GT. IM1(MODE)) THEN
34995         W=HB
34996        ELSE
34997         TOL=TOL*SIGN(Z1,HB)
34998         P=(B-A)*FB
34999         LMT(1)=IE .LE. 1
35000         IF(LMT(MODE)) THEN
35001          Q=FA-FB
35002          LMT(2)=.FALSE.
35003         ELSE
35004          FDB=(FD-FB)/(D-B)
35005          FDA=(FD-FA)/(D-A)
35006          P=FDA*P
35007          Q=FDB*FA-FDA*FB
35008         END IF
35009         IF(P .LT. 0) THEN
35010          P=-P
35011          Q=-Q
35012         END IF
35013         IF(IE .EQ. IM2(MODE)) P=P+P
35014         IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
35015          W=TOL
35016         ELSEIF(P .LT. HB*Q) THEN
35017          W=P/Q
35018         ELSE
35019          W=HB
35020         END IF
35021        END IF
35022        D=A
35023        A=B
35024        FD=FA
35025        FA=FB
35026        B=B+W
35027        MF=MF+1
35028        IF(MF .GT. MAXF) THEN
35029         WRITE(LO,102) NAME
35030         GO TO 99
35031        ENDIF
35032        FB=F(B)
35033        IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35034        IF(W .EQ. HB) GO TO 2
35035        IE=IE+1
35036        GO TO 3
35037       END IF
35038    99 CONTINUE
35039       PHO_DZEROX=C
35040       RETURN
35041   100 FORMAT(1X,A,': mode = ',I3,' illegal')
35042   101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35043   102 FORMAT(1X,A,': too many function calls')
35044
35045       END
35046
35047 *$ CREATE PHO_EXPINT.FOR
35048 *COPY PHO_EXPINT
35049 CDECK  ID>, PHO_EXPINT
35050       DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35051 C***********************************************************************
35052 C
35053 C     function to calculate  E_i(x) = -E_1(-x)
35054 C
35055 C     based on CERNLIB C337   (changed by R.Engel 10/1993)
35056 C
35057 C***********************************************************************
35058       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35059       SAVE
35060
35061 C  input/output channels
35062       INTEGER LI,LO
35063       COMMON /POINOU/ LI,LO
35064
35065       DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35066       DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35067       DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35068
35069       DATA  X0 /0.37250 74107 8137D0/
35070       DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35071       DATA P1
35072      1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35073      2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35074      3 -4.34981 43832 952D+2/
35075       DATA Q1
35076      1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35077      2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35078      3 +7.53585 64359 843D+2/
35079       DATA P2
35080      1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35081      2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35082      3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35083      4 +4.65627 10797 510D-7/
35084       DATA Q2
35085      1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35086      2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35087      3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35088      4 +1.00000 00000 000D+0/
35089       DATA P3
35090      1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35091      2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35092      3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35093       DATA Q3
35094      1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35095      2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35096      3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35097       DATA P4
35098      1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35099      2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35100      3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35101      4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35102       DATA Q4
35103      1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35104      2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35105      3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35106      4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35107       DATA A1
35108      1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35109      2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35110      3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35111      4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35112       DATA B1
35113      1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35114      2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35115      3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35116      4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35117       DATA A2
35118      1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35119      2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35120      3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35121      4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35122       DATA B2
35123      1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35124      2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35125      3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35126      4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35127       DATA A3
35128      1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35129      2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35130      3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35131       DATA B3
35132      1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35133      2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35134      3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35135 C
35136 C  conversion to E_i function
35137       X = -RXM
35138 C
35139       IF(X .LE. XL(1)) THEN
35140        AP=A3(1)-X
35141        DO 1 I = 2,5
35142     1  AP=A3(I)-X+B3(I)/AP
35143        Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35144       ELSEIF(X .LE. XL(2)) THEN
35145        AP=A2(1)-X
35146        DO 2 I = 2,7
35147     2     AP=A2(I)-X+B2(I)/AP
35148        Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35149       ELSEIF(X .LE. XL(3)) THEN
35150        AP=A1(1)-X
35151        DO 3 I = 2,7
35152     3     AP=A1(I)-X+B1(I)/AP
35153        Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35154       ELSEIF(X .LT. XL(4)) THEN
35155        V=-2.D0*(X/3.D0+1.D0)
35156        BP=0.D0
35157        DP=P4(1)
35158        DO 4 I = 2,8
35159           AP=BP
35160           BP=DP
35161     4     DP=P4(I)-AP+V*BP
35162        BQ=0.D0
35163        DQ=Q4(1)
35164        DO 14 I = 2,8
35165           AQ=BQ
35166           BQ=DQ
35167    14     DQ=Q4(I)-AQ+V*BQ
35168        Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35169       ELSEIF(X .EQ. XL(4)) THEN
35170 *      CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35171 *      IF(MFLAG) THEN
35172 *       IF(LGFILE .EQ. 0) THEN
35173 *        WRITE(LO,100) ENAME
35174 *       ELSE
35175 *        WRITE(LGFILE,100) ENAME
35176 *       ENDIF
35177 *      ENDIF
35178 *      IF(.NOT.RFLAG) CALL ABEND
35179        PHO_EXPINT=0.D0
35180        RETURN
35181       ELSEIF(X .LT. XL(5)) THEN
35182        AP=P1(1)
35183        AQ=Q1(1)
35184        DO 5 I = 2,5
35185           AP=P1(I)+X*AP
35186     5     AQ=Q1(I)+X*AQ
35187        Y=-LOG(X)+AP/AQ
35188       ELSEIF(X .LE. XL(6)) THEN
35189        Y=1.D0/X
35190        AP=P2(1)
35191        AQ=Q2(1)
35192        DO 6 I = 2,7
35193           AP=P2(I)+Y*AP
35194     6     AQ=Q2(I)+Y*AQ
35195        Y=EXP(-X)*AP/AQ
35196       ELSE
35197        Y=1.D0/X
35198        AP=P3(1)
35199        AQ=Q3(1)
35200        DO 7 I = 2,6
35201           AP=P3(I)+Y*AP
35202     7     AQ=Q3(I)+Y*AQ
35203        Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35204       ENDIF
35205 C  sign conversion to E_i
35206       PHO_EXPINT=-Y
35207
35208       END
35209
35210 *$ CREATE PHO_RNDBET.FOR
35211 *COPY PHO_RNDBET
35212 CDECK  ID>, PHO_RNDBET
35213       DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35214 C********************************************************************
35215 C
35216 C     RANDOM NUMBER GENERATION FROM BETA
35217 C     DISTRIBUTION IN REGION  0 < X < 1.
35218 C     F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35219 C                                                        *GAMM(ETA))
35220 C
35221 C********************************************************************
35222       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35223       SAVE
35224
35225       Y = PHO_RNDGAM(1.D0,GAM)
35226       Z = PHO_RNDGAM(1.D0,ETA)
35227
35228       PHO_RNDBET = Y/(Y+Z)
35229
35230       END
35231
35232 *$ CREATE PHO_RNDGAM.FOR
35233 *COPY PHO_RNDGAM
35234 CDECK  ID>, PHO_RNDGAM
35235       DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35236 C********************************************************************
35237 C
35238 C     RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35239 C     F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35240 C
35241 C********************************************************************
35242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35243       SAVE
35244 C
35245       NCOU=0
35246       N = ETA
35247       F = ETA - N
35248       IF(F.EQ.0.D0) GOTO 20
35249    10 R = DT_RNDM(ETA)
35250       NCOU=NCOU+1
35251       IF (NCOU.GE.11) GOTO 20
35252       IF(R.LT.F/(F+2.71828D0)) GOTO 30
35253       YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35254       IF(ABS(YYY).GT.50.D0) GOTO 20
35255       Y = EXP(YYY)
35256       IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35257       GOTO 40
35258    20 Y = 0.D0
35259       GOTO 50
35260    30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35261       IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35262    40 IF(N.EQ.0) GOTO 70
35263    50 Z = 1.D0
35264       DO 60 I = 1,N
35265    60 Z = Z*DT_RNDM(Y)
35266       Y = Y-LOG(Z+1.0D-9)
35267    70 PHO_RNDGAM = Y/ALAM
35268       RETURN
35269       END
35270
35271 *$ CREATE PHO_SFECFE.FOR
35272 *COPY PHO_SFECFE
35273 CDECK  ID>, PHO_SFECFE
35274       SUBROUTINE PHO_SFECFE(SFE,CFE)
35275 C**********************************************************************
35276 C
35277 C     fast random SIN(X) COS(X) selection
35278 C
35279 C**********************************************************************
35280       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35281       SAVE
35282 C
35283     1 CONTINUE
35284         X=DT_RNDM(XX)
35285         Y=DT_RNDM(YY)
35286         XX=X*X
35287         YY=Y*Y
35288         XY=XX+YY
35289       IF(XY.GT.1.D0) GOTO 1
35290       CFE=(XX-YY)/XY
35291       SFE=2.D0*X*Y/XY
35292       IF(DT_RNDM(XY).LT.0.5D0) THEN
35293         SFE=-SFE
35294       ENDIF
35295       END
35296
35297 *$ CREATE PHO_SWAPD.FOR
35298 *COPY PHO_SWAPD
35299 CDECK  ID>, PHO_SWAPD
35300       SUBROUTINE PHO_SWAPD(D1,D2)
35301 C********************************************************************
35302 C
35303 C     exchange of argument values (double precision)
35304 C
35305 C********************************************************************
35306       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35307       D = D1
35308       D1 = D2
35309       D2 = D
35310       END
35311
35312 *$ CREATE PHO_SWAPI.FOR
35313 *COPY PHO_SWAPI
35314 CDECK  ID>, PHO_SWAPI
35315       SUBROUTINE PHO_SWAPI(I1,I2)
35316 C********************************************************************
35317 C
35318 C     exchange of argument values (integer)
35319 C
35320 C********************************************************************
35321       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35322       K = I1
35323       I1 = I2
35324       I2 = K
35325       END
35326
35327 *$ CREATE PHO_HADCSL.FOR
35328 *COPY PHO_HADCSL
35329 CDECK  ID>, PHO_HADCSL
35330       SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35331      &                     SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35332 C***********************************************************************
35333 C
35334 C     low-energy cross section parametrizations
35335 C
35336 C     input:   ID1,ID2     PDG IDs of particles (meson first)
35337 C              ECM         c.m. energy (GeV)
35338 C              PLAB        lab. momentum (second particle at rest)
35339 C              IMODE       1    ECM given, PLAB ignored
35340 C                          2    PLAB given, ECM ignored
35341 C
35342 C     output:  SIGTOT      total cross section (mb)
35343 C              SIGEL       elastic cross section (mb)
35344 C              SIGDIF      diffracive cross section (sd-1,sd-2,dd), (mb)
35345 C              SLOPE       forward elastic slope (GeV**-2)
35346 C              RHO         real/imaginary part of elastic amplitude
35347 C
35348 C     comments:
35349 C
35350 C     - low-energy data interpolation uses PDG fits from 1992 issue
35351 C     - high-energy extrapolation by Donnachie-Landshoff like fit made
35352 C       by PDG 1996
35353 C     - analytic extension of amplitude to calculate rho
35354 C
35355 C***********************************************************************
35356       IMPLICIT NONE
35357       SAVE
35358
35359       INTEGER ID1,ID2,IMODE
35360       DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35361
35362 C  input/output channels
35363       INTEGER LI,LO
35364       COMMON /POINOU/ LI,LO
35365 C  some constants
35366       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35367       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35368      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35369 C  model switches and parameters
35370       CHARACTER*8 MDLNA
35371       INTEGER ISWMDL,IPAMDL
35372       DOUBLE PRECISION PARMDL
35373       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35374
35375       INTEGER K
35376       DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35377      &  SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35378
35379       DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35380
35381       DATA TPDG92  /
35382      &  3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35383      &  3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35384      &  5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35385      &  5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35386      &  4.D0, 340.D0,  16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35387      &  4.D0, 340.D0,  0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35388      &  2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35389      &  2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35390      &  2.D0, 310.D0,  18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35391      &  2.D0, 310.D0,  5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35392      &  3.D0, 310.D0,  32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35393      &  3.D0, 310.D0,  7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0  /
35394
35395       DATA TPDG96  /
35396      &  50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35397      &         77.15D0,-21.05D0,0.46D0,0.9D0,
35398      &  50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35399      &         77.15D0,21.05D0,0.46D0,0.9D0,
35400      &  10.D0, 13.70,0.079D0,0.25D0,0.D0,
35401      &         31.85D0,-4.05D0,0.45D0,0.9D0,
35402      &  10.D0, 13.70,0.079D0,0.25D0,0.D0,
35403      &         31.85D0,4.05D0,0.45D0,0.9D0,
35404      &  10.D0, 12.20,0.079D0,0.25D0,0.D0,
35405      &         17.35D0,-9.05D0,0.50D0,0.9D0,
35406      &  10.D0, 12.20,0.079D0,0.25D0,0.D0,
35407      &         17.35D0,9.05D0,0.50D0,0.9D0  /
35408
35409       DATA BURQ83 /
35410      &  11.13D0, -6.21D0, 0.30D0,
35411      &  11.13D0,  7.23D0, 0.30D0,
35412      &  9.11D0,  -0.73D0, 0.28D0,
35413      &  9.11D0,   0.65D0, 0.28D0,
35414      &  8.55D0,  -5.98D0, 0.28D0,
35415      &  8.55D0,   1.60D0, 0.28D0  /
35416
35417       DATA XMA /
35418      &  2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35419
35420 C  find index
35421       IF(ID2.NE.2212) THEN
35422         GOTO 100
35423       ELSE IF(ID1.EQ.2212) THEN
35424         K = 1
35425       ELSE IF(ID1.EQ.-2212) THEN
35426         K = 2
35427       ELSE IF(ID1.EQ.211) THEN
35428         K = 3
35429       ELSE IF(ID1.EQ.-211) THEN
35430         K = 4
35431       ELSE IF(ID1.EQ.321) THEN
35432         K = 5
35433       ELSE IF(ID1.EQ.-321) THEN
35434         K = 6
35435       ELSE
35436         GOTO 100
35437       ENDIF
35438
35439 C  calculate lab momentum
35440       IF(IMODE.EQ.1) THEN
35441         SS = ECM**2
35442         E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35443         PL = SQRT(E1*E1-XMA(K)**2)
35444       ELSE IF(IMODE.EQ.2) THEN
35445         PL = PLAB
35446         SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35447         ECM = SQRT(SS)
35448       ELSE
35449         WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35450         RETURN
35451       ENDIF
35452       PLL = LOG(PL)
35453
35454 C  check against lower limit
35455       IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35456
35457       XP  = TPDG96(2,K)*SS**TPDG96(3,K)
35458       YP  = TPDG96(6,K)/SS**TPDG96(8,K)
35459       YM  = TPDG96(7,K)/SS**TPDG96(8,K)
35460
35461       PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35462       PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35463       RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35464       SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35465
35466 C  select energy range and interpolation method
35467       IF(PL.LT.TPDG96(1,K)) THEN
35468         SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35469      &          + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35470         SIGEL  = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35471      &          + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35472       ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35473         SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35474      &          + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35475         SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35476      &          + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35477         SIGTO2 = YP+YM+XP
35478         SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35479         X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35480         X1 = 1.D0 - X2
35481         SIGTOT = SIGTO2*X2 + SIGTO1*X1
35482         SIGEL  = SIGEL2*X2 + SIGEL1*X1
35483       ELSE
35484         SIGTOT = YP+YM+XP
35485         SIGEL  = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35486       ENDIF
35487
35488 C  no parametrization of diffraction implemented
35489       SIGDIF(1) = -1.D0
35490       SIGDIF(2) = -1.D0
35491       SIGDIF(3) = -1.D0
35492
35493       RETURN
35494
35495  100  CONTINUE
35496         WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35497      &    'invalid particle combination: ',ID1,ID2
35498         RETURN
35499
35500  200  CONTINUE
35501         WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35502      &    'energy too small (Ecm,Plab): ',ECM,PLAB
35503
35504       END
35505
35506 *$ CREATE PHO_CSDIFF.FOR
35507 *COPY PHO_CSDIFF
35508 CDECK  ID>, PHO_CSDIFF
35509       SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35510      &  sig_sd1,sig_sd2,sig_dd)
35511 C***********************************************************************
35512 C
35513 C     cross section for diffraction dissociation according to
35514 C     Goulianos' parametrization (Ref: PL B358 (1995) 379)
35515 C
35516 C     in addition rescaling for different particles is applied using
35517 C     internal rescaling tables (not implemented yet)
35518 C
35519 C     input:     Id1/2       PDG ID's of incoming particles
35520 C                SS          squared c.m. energy (GeV**2)
35521 C                Xi_min      min. diff mass (squared) = Xi_min*SS
35522 C                Xi_max      max. diff mass (squared) = Xi_max*SS
35523 C
35524 C     output:    sig_sd1     cross section for diss. of particle 1 (mb)
35525 C                sig_sd2     cross section for diss. of particle 2 (mb)
35526 C                sig_dd      cross section for diss. of both particles
35527 C
35528 C***********************************************************************
35529       IMPLICIT NONE
35530       SAVE
35531
35532       INTEGER Id1,Id2
35533       DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35534
35535 C  input/output channels
35536       INTEGER LI,LO
35537       COMMON /POINOU/ LI,LO
35538 C  some constants
35539       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35540       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35541      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35542
35543       DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35544       DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35545      &  fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35546      &  xms_1,xms_2,CSdiff
35547
35548       INTEGER Ngau1,Ngau2,i1,i2
35549
35550 C  model parameters
35551
35552       DATA delta    / 0.104d0 /
35553       DATA alphap   / 0.25d0 /
35554       DATA beta0    / 6.56d0 /
35555       DATA gpom0    / 1.21d0 /
35556       DATA xm_p     / 0.938d0 /
35557       DATA x_rad2   / 0.71d0 /
35558
35559 C  integration precision
35560
35561       DATA Ngau1    / 96 /
35562       DATA Ngau2    / 96 /
35563
35564       sig_sd1 = 0.d0
35565       sig_sd2 = 0.d0
35566       sig_dd  = 0.d0
35567
35568       IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35569
35570         xm4_p2 = 4.D0*xm_p**2
35571         fac = beta0**2/(16.D0*PI)
35572
35573         t1 = -5.D0
35574         t2 = 0.D0
35575         tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35576         tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35577
35578 C  flux renormalization and cross section
35579
35580         Xnorm  = 0.d0
35581
35582         xil = log(1.5d0/SS)
35583         xiu = log(0.1d0)
35584
35585         IF(xiu.LE.xil) goto 1000
35586
35587         CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
35588         CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
35589
35590         do i1=1,Ngau1
35591
35592           xi = exp(xpos1(i1))
35593           w_xi = Xwgh1(i1)
35594
35595           do i2=1,Ngau2
35596
35597             tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35598
35599             alpha_t =  1.D0+delta+alphap*tt
35600             f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35601
35602             Xnorm = Xnorm
35603      &        + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35604
35605           enddo
35606         enddo
35607
35608         Xnorm = Xnorm*fac
35609
35610  1000   continue
35611
35612         XIL = LOG(Xi_min)
35613         XIU = LOG(Xi_max)
35614
35615         T1 = -5.D0
35616         T2 = 0.D0
35617
35618         TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35619         TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35620
35621 C  single diffraction diss. cross section
35622
35623         CSdiff = 0.d0
35624
35625         IF(XIU.LE.XIL) goto 2000
35626
35627         CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
35628         CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
35629
35630         do i1=1,Ngau1
35631
35632           xi = exp(xpos1(i1))
35633           w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
35634
35635           do i2=1,Ngau2
35636
35637             tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35638
35639             alpha_t =  1.D0+delta+alphap*tt
35640             f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35641
35642             CSdiff = CSdiff
35643      &        + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35644
35645           enddo
35646         enddo
35647
35648         CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
35649
35650 *       WRITE(LO,'(1x,1p,4e14.3)')
35651 *    &    sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
35652
35653         sig_sd1 = CSdiff
35654         sig_sd2 = CSdiff
35655
35656  2000   continue
35657
35658 C  double diffraction dissociation cross section
35659
35660         CSdiff = 0.d0
35661
35662         xil = log(1.5d0/SS)
35663         xiu = log(Xi_max/1.5d0)
35664
35665         IF(xiu.LE.xil) goto 3000
35666
35667         fac = (beta0*gpom0*SS**delta
35668      &         /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
35669      &       /(2.d0*alphap)
35670
35671         CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
35672
35673         do i1=1,Ngau1
35674
35675           xi = exp(xpos1(i1))
35676           xms_1 = xi*SS
35677
35678           xiu = log(Xi_max/(xi*SS))
35679
35680           if(xil.lt.xiu) then
35681
35682             CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
35683
35684             do i2=1,Ngau2
35685
35686               xms_2 = exp(xpos2(i2))*SS
35687               CSdiff = CSdiff
35688      &          + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
35689      &            *xwgh1(i1)*xwgh2(i2)
35690
35691             enddo
35692
35693           endif
35694
35695         enddo
35696
35697         sig_dd = CSdiff*fac*GEV2MB
35698
35699  3000   continue
35700
35701       ELSE
35702
35703         WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
35704      &    'invalid particle combination (Id1/2)',Id1,Id2
35705
35706       ENDIF
35707
35708       END
35709
35710 *$ CREATE PHO_ALLM97.FOR
35711 *COPY PHO_ALLM97
35712 CDECK  ID>, PHO_ALLM97
35713       DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
35714 C**********************************************************************
35715 C
35716 C     ALLM97 parametrization for gamma*-p cross section
35717 C     (for F2 see comments, code adapted from V. Shekelyan, H1)
35718 C
35719 C**********************************************************************
35720       IMPLICIT NONE
35721       SAVE
35722
35723 C  input/output channels
35724       INTEGER LI,LO
35725       COMMON /POINOU/ LI,LO
35726
35727       DOUBLE PRECISION Q2,W
35728       DOUBLE PRECISION M02,M12,LAM2,M22
35729       DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
35730       DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
35731       DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
35732      &                 AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
35733       DATA ALFA,XMP2 /112.2D0 , .8802D0 /
35734
35735       W2=W*W
35736       PHO_ALLM97 = 0.D0
35737
35738 C  pomeron
35739       S11   =   0.28067D0
35740       S12   =   0.22291D0
35741       S13   =   2.1979D0
35742       A11   =  -0.0808D0
35743       A12   =  -0.44812D0
35744       A13   =   1.1709D0
35745       B11   =   0.60243D0
35746       B12   =   1.3754D0
35747       B13   =   1.8439D0
35748       M12   =  49.457D0
35749
35750 C  reggeon
35751       S21   =   0.80107D0
35752       S22   =   0.97307D0
35753       S23   =   3.4942D0
35754       A21   =   0.58400D0
35755       A22   =   0.37888D0
35756       A23   =   2.6063D0
35757       B21   =   0.10711D0
35758       B22   =   1.9386D0
35759       B23   =   0.49338D0
35760       M22   =   0.15052D0
35761 C
35762       M02   =   0.31985D0
35763       LAM2  =   0.065270D0
35764       Q02   =   0.46017D0 +LAM2
35765
35766 C
35767       S=0.
35768       T=LOG((Q2+Q02)/LAM2)
35769       T0=LOG(Q02/LAM2)
35770       IF(Q2.GT.0.D0) S=LOG(T/T0)
35771       Z=1.D0
35772
35773       IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
35774
35775       IF(S.LT.0.01D0) THEN
35776
35777 C   pomeron part
35778
35779         XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35780
35781         AP=A11
35782         BP=B11**2
35783
35784         SP=S11
35785         F2P=SP*XP**AP*Z**BP
35786
35787 C   reggeon part
35788
35789         XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35790
35791         AR=A21
35792         BR=B21**2
35793
35794         SR=S21
35795         F2R=SR*XR**AR*Z**BR
35796
35797       ELSE
35798
35799 C   pomeron part
35800
35801         XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35802
35803         AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
35804
35805         BP=B11**2+B12**2*S**B13
35806
35807         SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
35808
35809         F2P=SP*XP**AP*Z**BP
35810
35811 C   reggeon part
35812
35813         XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35814
35815         AR=A21+A22*S**A23
35816         BR=B21**2+B22**2*S**B23
35817
35818         SR=S21+S22*S**S23
35819         F2R=SR*XR**AR*Z**BR
35820
35821       ENDIF
35822
35823 *     F2 = (F2P+F2R)*Q2/(Q2+M02)
35824
35825       CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
35826       PHO_ALLM97 = CIN*(F2P+F2R)
35827
35828       END
35829
35830 *$ CREATE PHO_DOR98LO.FOR
35831 *COPY PHO_DOR98LO
35832 CDECK  ID>, PHO_DOR98LO
35833       SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
35834 C***********************************************************************
35835 C
35836 C   GRV98 parton densities, leading order set
35837 C
35838 C                  For a detailed explanation see
35839 C                   M. Glueck, E. Reya, A. Vogt :
35840 C        hep-ph/9806404  =  DO-TH 98/07  =  WUE-ITP-98-019
35841 C                  (To appear in Eur. Phys. J. C)
35842 C
35843 C   interpolation routine based on the original GRV98PA routine,
35844 C   adapted to define interpolation table as DATA statements
35845 C
35846 C                                                   (R.Engel, 09/98)
35847 C
35848 C
35849 C   INPUT:   X  =  Bjorken-x        (between  1.E-9 and 1.)
35850 C            Q2 =  scale in GeV**2  (between  0.8 and 1.E6)
35851 C
35852 C   OUTPUT:  UV = u - u(bar),  DV = d - d(bar),  US = u(bar),
35853 C            DS = d(bar),  SS = s = s(bar),  GL = gluon.
35854 C            Always x times the distribution is returned.
35855 C
35856 C******************************************************i****************
35857       IMPLICIT DOUBLE PRECISION (A-H, O-Z)
35858       SAVE
35859
35860 C  input/output channels
35861       INTEGER LI,LO
35862       COMMON /POINOU/ LI,LO
35863
35864       PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
35865       DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
35866      1          XSF(NX,NQ), XGF(NX,NQ),
35867      2          XT(NARG), NA(NARG), ARRF(NX+NQ)
35868
35869       DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
35870      &  XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
35871
35872       EQUIVALENCE (XUVF(1,1),XUVF_L(1))
35873       EQUIVALENCE (XDVF(1,1),XDVF_L(1))
35874       EQUIVALENCE (XDEF(1,1),XDEF_L(1))
35875       EQUIVALENCE (XUDF(1,1),XUDF_L(1))
35876       EQUIVALENCE (XSF(1,1),XSF_L(1))
35877       EQUIVALENCE (XGF(1,1),XGF_L(1))
35878
35879       DATA (ARRF(K),K=    1,   95) /
35880      &  -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
35881      &  -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
35882      &  -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
35883      &  -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
35884      &  -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
35885      &  -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
35886      &  -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
35887      &  -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
35888      &  -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
35889      &  -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
35890      &  -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
35891      &  -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
35892      &  -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
35893      &  -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
35894      &   2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
35895      &   2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
35896      &   4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
35897      &   7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
35898      &   1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
35899       DATA (XUVF_L(K),K=    1,  114) /
35900      &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
35901      &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
35902      &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
35903      &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
35904      &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
35905      &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
35906      &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
35907      &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
35908      &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
35909      &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
35910      &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
35911      &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
35912      &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
35913      &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
35914      &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
35915      &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
35916      &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
35917      &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
35918      &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
35919       DATA (XUVF_L(K),K=  115,  228) /
35920      &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
35921      &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
35922      &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
35923      &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
35924      &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
35925      &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
35926      &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
35927      &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
35928      &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
35929      &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
35930      &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
35931      &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
35932      &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
35933      &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
35934      &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
35935      &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
35936      &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
35937      &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
35938      &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
35939       DATA (XUVF_L(K),K=  229,  342) /
35940      &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
35941      &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
35942      &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
35943      &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
35944      &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
35945      &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
35946      &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
35947      &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
35948      &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
35949      &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
35950      &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
35951      &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
35952      &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
35953      &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
35954      &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
35955      &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
35956      &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
35957      &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
35958      &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
35959       DATA (XUVF_L(K),K=  343,  456) /
35960      &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
35961      &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
35962      &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
35963      &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
35964      &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
35965      &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
35966      &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
35967      &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
35968      &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
35969      &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
35970      &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
35971      &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
35972      &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
35973      &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
35974      &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
35975      &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
35976      &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
35977      &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
35978      &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
35979       DATA (XUVF_L(K),K=  457,  570) /
35980      &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
35981      &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
35982      &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
35983      &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
35984      &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
35985      &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
35986      &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
35987      &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
35988      &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
35989      &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
35990      &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
35991      &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
35992      &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
35993      &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
35994      &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
35995      &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
35996      &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
35997      &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
35998      &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
35999       DATA (XUVF_L(K),K=  571,  684) /
36000      &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
36001      &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
36002      &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
36003      &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
36004      &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
36005      &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
36006      &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
36007      &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
36008      &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
36009      &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
36010      &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
36011      &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
36012      &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
36013      &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
36014      &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
36015      &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
36016      &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
36017      &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
36018      &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
36019       DATA (XUVF_L(K),K=  685,  798) /
36020      &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
36021      &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36022      &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36023      &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36024      &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36025      &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36026      &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36027      &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36028      &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36029      &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36030      &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36031      &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36032      &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36033      &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36034      &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36035      &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36036      &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36037      &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36038      &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36039       DATA (XUVF_L(K),K=  799,  912) /
36040      &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36041      &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36042      &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36043      &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36044      &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36045      &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36046      &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36047      &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36048      &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36049      &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36050      &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36051      &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36052      &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36053      &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36054      &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36055      &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36056      &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36057      &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36058      &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36059       DATA (XUVF_L(K),K=  913, 1026) /
36060      &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36061      &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36062      &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36063      &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36064      &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36065      &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36066      &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36067      &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36068      &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36069      &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36070      &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36071      &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36072      &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36073      &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36074      &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36075      &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36076      &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36077      &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36078      &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36079       DATA (XUVF_L(K),K= 1027, 1140) /
36080      &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36081      &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36082      &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36083      &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36084      &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36085      &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36086      &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36087      &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36088      &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36089      &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36090      &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36091      &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36092      &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36093      &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36094      &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36095      &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36096      &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36097      &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36098      &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36099       DATA (XUVF_L(K),K= 1141, 1254) /
36100      &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36101      &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36102      &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36103      &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36104      &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36105      &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36106      &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36107      &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36108      &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36109      &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36110      &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36111      &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36112      &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36113      &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36114      &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36115      &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36116      &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36117      &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36118      &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36119       DATA (XUVF_L(K),K= 1255, 1368) /
36120      &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36121      &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36122      &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36123      &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36124      &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36125      &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36126      &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36127      &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36128      &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36129      &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36130      &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36131      &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36132      &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36133      &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36134      &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36135      &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36136      &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36137      &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36138      &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36139       DATA (XUVF_L(K),K= 1369, 1482) /
36140      &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36141      &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36142      &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36143      &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36144      &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36145      &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36146      &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36147      &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36148      &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36149      &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36150      &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36151      &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36152      &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36153      &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36154      &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36155      &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36156      &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36157      &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36158      &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36159       DATA (XUVF_L(K),K= 1483, 1596) /
36160      &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36161      &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36162      &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36163      &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36164      &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36165      &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36166      &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36167      &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36168      &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36169      &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36170      &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36171      &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36172      &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36173      &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36174      &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36175      &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36176      &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36177      &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36178      &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36179       DATA (XUVF_L(K),K= 1597, 1710) /
36180      &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36181      &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36182      &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36183      &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36184      &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36185      &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36186      &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36187      &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36188      &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36189      &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36190      &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36191      &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36192      &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36193      &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36194      &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36195      &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36196      &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36197      &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36198      &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36199       DATA (XUVF_L(K),K= 1711, 1824) /
36200      &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36201      &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36202      &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36203      &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36204      &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36205      &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36206      &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36207      &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36208      &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36209      &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36210      &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36211      &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36212      &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36213      &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36214      &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36215      &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36216      &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36217      &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36218      &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36219       DATA (XUVF_L(K),K= 1825, 1836) /
36220      &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36221      &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36222       DATA (XDVF_L(K),K=    1,  114) /
36223      &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36224      &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36225      &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36226      &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36227      &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36228      &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36229      &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36230      &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36231      &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36232      &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36233      &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36234      &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36235      &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36236      &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36237      &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36238      &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36239      &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36240      &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36241      &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36242       DATA (XDVF_L(K),K=  115,  228) /
36243      &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36244      &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36245      &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36246      &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36247      &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36248      &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36249      &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36250      &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36251      &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36252      &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36253      &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36254      &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36255      &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36256      &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36257      &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36258      &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36259      &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36260      &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36261      &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36262       DATA (XDVF_L(K),K=  229,  342) /
36263      &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36264      &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36265      &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36266      &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36267      &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36268      &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36269      &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36270      &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36271      &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36272      &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36273      &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36274      &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36275      &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36276      &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36277      &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36278      &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36279      &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36280      &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36281      &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36282       DATA (XDVF_L(K),K=  343,  456) /
36283      &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36284      &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36285      &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36286      &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36287      &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36288      &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36289      &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36290      &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36291      &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36292      &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36293      &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36294      &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36295      &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36296      &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36297      &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36298      &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36299      &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36300      &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36301      &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36302       DATA (XDVF_L(K),K=  457,  570) /
36303      &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36304      &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36305      &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36306      &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36307      &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36308      &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36309      &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36310      &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36311      &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36312      &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36313      &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36314      &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36315      &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36316      &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36317      &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36318      &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36319      &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36320      &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36321      &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36322       DATA (XDVF_L(K),K=  571,  684) /
36323      &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36324      &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36325      &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36326      &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36327      &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36328      &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36329      &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36330      &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36331      &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36332      &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36333      &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36334      &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36335      &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36336      &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36337      &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36338      &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36339      &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36340      &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36341      &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36342       DATA (XDVF_L(K),K=  685,  798) /
36343      &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36344      &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36345      &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36346      &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36347      &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36348      &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36349      &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36350      &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36351      &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36352      &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36353      &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36354      &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36355      &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36356      &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36357      &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36358      &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36359      &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36360      &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36361      &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36362       DATA (XDVF_L(K),K=  799,  912) /
36363      &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36364      &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36365      &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36366      &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36367      &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36368      &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36369      &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36370      &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36371      &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36372      &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36373      &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36374      &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36375      &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36376      &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36377      &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36378      &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36379      &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36380      &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36381      &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36382       DATA (XDVF_L(K),K=  913, 1026) /
36383      &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36384      &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36385      &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36386      &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36387      &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36388      &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36389      &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36390      &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36391      &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36392      &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36393      &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36394      &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36395      &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36396      &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36397      &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36398      &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36399      &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36400      &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36401      &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36402       DATA (XDVF_L(K),K= 1027, 1140) /
36403      &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36404      &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36405      &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36406      &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36407      &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36408      &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36409      &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36410      &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36411      &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36412      &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36413      &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36414      &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36415      &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36416      &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36417      &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36418      &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36419      &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36420      &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36421      &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36422       DATA (XDVF_L(K),K= 1141, 1254) /
36423      &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36424      &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36425      &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36426      &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36427      &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36428      &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36429      &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36430      &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36431      &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36432      &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36433      &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36434      &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36435      &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36436      &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36437      &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36438      &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36439      &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36440      &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36441      &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36442       DATA (XDVF_L(K),K= 1255, 1368) /
36443      &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36444      &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36445      &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36446      &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36447      &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36448      &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36449      &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36450      &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36451      &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36452      &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36453      &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36454      &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36455      &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36456      &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36457      &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36458      &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36459      &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36460      &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36461      &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36462       DATA (XDVF_L(K),K= 1369, 1482) /
36463      &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36464      &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36465      &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36466      &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36467      &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36468      &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36469      &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36470      &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36471      &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36472      &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36473      &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36474      &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36475      &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36476      &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36477      &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36478      &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36479      &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36480      &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36481      &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36482       DATA (XDVF_L(K),K= 1483, 1596) /
36483      &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36484      &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36485      &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36486      &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36487      &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36488      &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36489      &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36490      &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36491      &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36492      &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36493      &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36494      &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36495      &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36496      &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36497      &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36498      &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36499      &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36500      &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36501      &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36502       DATA (XDVF_L(K),K= 1597, 1710) /
36503      &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36504      &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36505      &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36506      &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36507      &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36508      &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36509      &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36510      &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36511      &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36512      &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36513      &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36514      &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36515      &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36516      &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36517      &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36518      &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36519      &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36520      &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36521      &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36522       DATA (XDVF_L(K),K= 1711, 1824) /
36523      &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36524      &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36525      &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36526      &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36527      &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36528      &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36529      &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36530      &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36531      &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36532      &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36533      &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36534      &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36535      &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36536      &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36537      &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36538      &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36539      &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36540      &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36541      &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36542       DATA (XDVF_L(K),K= 1825, 1836) /
36543      &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36544      &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36545       DATA (XDEF_L(K),K=    1,  114) /
36546      &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36547      &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36548      &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36549      &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36550      &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36551      &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36552      &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36553      &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36554      &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36555      &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36556      &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36557      &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36558      &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36559      &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36560      &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36561      &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36562      &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36563      &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36564      &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36565       DATA (XDEF_L(K),K=  115,  228) /
36566      &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36567      &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36568      &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36569      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36570      &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36571      &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36572      &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36573      &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36574      &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36575      &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36576      &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36577      &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36578      &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
36579      &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
36580      &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36581      &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
36582      &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
36583      &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
36584      &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
36585       DATA (XDEF_L(K),K=  229,  342) /
36586      &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
36587      &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
36588      &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
36589      &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
36590      &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
36591      &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
36592      &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
36593      &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
36594      &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
36595      &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
36596      &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
36597      &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
36598      &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
36599      &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
36600      &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
36601      &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
36602      &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
36603      &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
36604      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
36605       DATA (XDEF_L(K),K=  343,  456) /
36606      &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
36607      &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
36608      &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
36609      &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
36610      &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
36611      &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
36612      &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
36613      &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
36614      &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
36615      &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
36616      &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36617      &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
36618      &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
36619      &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
36620      &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
36621      &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
36622      &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
36623      &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
36624      &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
36625       DATA (XDEF_L(K),K=  457,  570) /
36626      &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
36627      &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
36628      &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36629      &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
36630      &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
36631      &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
36632      &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
36633      &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
36634      &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
36635      &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
36636      &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
36637      &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
36638      &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
36639      &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
36640      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
36641      &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
36642      &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
36643      &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
36644      &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
36645       DATA (XDEF_L(K),K=  571,  684) /
36646      &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
36647      &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
36648      &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
36649      &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
36650      &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
36651      &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
36652      &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36653      &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
36654      &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
36655      &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
36656      &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
36657      &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
36658      &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
36659      &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
36660      &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
36661      &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
36662      &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
36663      &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36664      &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
36665       DATA (XDEF_L(K),K=  685,  798) /
36666      &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
36667      &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
36668      &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
36669      &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
36670      &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
36671      &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
36672      &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
36673      &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
36674      &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
36675      &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
36676      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
36677      &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
36678      &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
36679      &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
36680      &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
36681      &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
36682      &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
36683      &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
36684      &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
36685       DATA (XDEF_L(K),K=  799,  912) /
36686      &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
36687      &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
36688      &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36689      &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
36690      &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
36691      &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
36692      &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
36693      &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
36694      &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
36695      &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
36696      &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
36697      &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
36698      &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
36699      &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36700      &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
36701      &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
36702      &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
36703      &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
36704      &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
36705       DATA (XDEF_L(K),K=  913, 1026) /
36706      &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
36707      &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
36708      &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
36709      &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
36710      &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
36711      &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
36712      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
36713      &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
36714      &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
36715      &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
36716      &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
36717      &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
36718      &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
36719      &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
36720      &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
36721      &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
36722      &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
36723      &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36724      &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
36725       DATA (XDEF_L(K),K= 1027, 1140) /
36726      &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
36727      &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
36728      &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
36729      &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
36730      &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
36731      &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
36732      &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
36733      &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
36734      &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
36735      &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36736      &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
36737      &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
36738      &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
36739      &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
36740      &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
36741      &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
36742      &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
36743      &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
36744      &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
36745       DATA (XDEF_L(K),K= 1141, 1254) /
36746      &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
36747      &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
36748      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
36749      &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
36750      &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
36751      &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
36752      &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
36753      &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
36754      &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
36755      &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
36756      &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
36757      &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
36758      &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
36759      &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36760      &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
36761      &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
36762      &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
36763      &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
36764      &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
36765       DATA (XDEF_L(K),K= 1255, 1368) /
36766      &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
36767      &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
36768      &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
36769      &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
36770      &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
36771      &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36772      &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
36773      &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
36774      &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
36775      &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
36776      &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
36777      &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
36778      &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
36779      &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
36780      &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
36781      &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
36782      &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
36783      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
36784      &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
36785       DATA (XDEF_L(K),K= 1369, 1482) /
36786      &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
36787      &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
36788      &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
36789      &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
36790      &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
36791      &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
36792      &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
36793      &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
36794      &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
36795      &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36796      &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
36797      &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
36798      &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
36799      &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
36800      &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
36801      &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
36802      &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
36803      &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
36804      &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
36805       DATA (XDEF_L(K),K= 1483, 1596) /
36806      &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
36807      &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36808      &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
36809      &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
36810      &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
36811      &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
36812      &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
36813      &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
36814      &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
36815      &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
36816      &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
36817      &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
36818      &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
36819      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
36820      &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
36821      &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
36822      &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
36823      &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
36824      &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
36825       DATA (XDEF_L(K),K= 1597, 1710) /
36826      &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
36827      &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
36828      &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
36829      &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
36830      &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
36831      &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36832      &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
36833      &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
36834      &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
36835      &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
36836      &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
36837      &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
36838      &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
36839      &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
36840      &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
36841      &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
36842      &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36843      &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
36844      &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
36845       DATA (XDEF_L(K),K= 1711, 1824) /
36846      &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
36847      &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
36848      &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
36849      &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
36850      &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
36851      &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
36852      &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
36853      &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
36854      &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
36855      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
36856      &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
36857      &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
36858      &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
36859      &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
36860      &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
36861      &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
36862      &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
36863      &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
36864      &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
36865       DATA (XDEF_L(K),K= 1825, 1836) /
36866      &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
36867      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
36868       DATA (XUDF_L(K),K=    1,  114) /
36869      &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
36870      &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
36871      &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
36872      &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
36873      &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
36874      &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
36875      &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
36876      &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
36877      &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
36878      &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
36879      &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
36880      &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
36881      &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
36882      &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
36883      &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
36884      &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
36885      &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
36886      &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
36887      &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
36888       DATA (XUDF_L(K),K=  115,  228) /
36889      &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
36890      &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
36891      &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
36892      &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
36893      &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
36894      &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
36895      &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
36896      &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
36897      &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
36898      &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
36899      &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
36900      &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
36901      &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
36902      &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
36903      &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
36904      &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
36905      &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
36906      &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
36907      &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
36908       DATA (XUDF_L(K),K=  229,  342) /
36909      &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
36910      &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
36911      &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
36912      &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
36913      &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
36914      &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
36915      &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
36916      &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
36917      &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
36918      &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
36919      &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
36920      &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
36921      &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
36922      &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
36923      &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
36924      &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
36925      &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
36926      &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
36927      &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
36928       DATA (XUDF_L(K),K=  343,  456) /
36929      &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
36930      &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
36931      &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
36932      &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
36933      &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
36934      &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
36935      &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
36936      &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
36937      &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
36938      &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
36939      &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
36940      &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
36941      &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
36942      &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
36943      &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
36944      &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
36945      &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
36946      &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
36947      &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
36948       DATA (XUDF_L(K),K=  457,  570) /
36949      &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
36950      &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
36951      &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
36952      &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
36953      &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
36954      &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
36955      &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
36956      &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
36957      &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
36958      &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
36959      &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
36960      &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
36961      &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
36962      &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
36963      &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
36964      &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
36965      &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
36966      &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
36967      &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
36968       DATA (XUDF_L(K),K=  571,  684) /
36969      &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
36970      &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
36971      &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
36972      &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
36973      &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
36974      &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
36975      &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
36976      &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
36977      &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
36978      &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
36979      &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
36980      &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
36981      &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
36982      &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
36983      &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
36984      &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
36985      &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
36986      &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
36987      &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
36988       DATA (XUDF_L(K),K=  685,  798) /
36989      &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
36990      &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
36991      &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
36992      &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
36993      &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
36994      &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
36995      &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
36996      &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
36997      &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
36998      &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
36999      &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
37000      &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
37001      &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
37002      &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
37003      &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
37004      &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
37005      &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
37006      &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
37007      &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
37008       DATA (XUDF_L(K),K=  799,  912) /
37009      &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
37010      &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
37011      &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
37012      &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
37013      &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
37014      &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
37015      &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
37016      &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
37017      &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
37018      &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
37019      &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
37020      &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
37021      &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37022      &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37023      &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37024      &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37025      &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37026      &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37027      &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37028       DATA (XUDF_L(K),K=  913, 1026) /
37029      &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37030      &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37031      &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37032      &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37033      &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37034      &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37035      &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37036      &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37037      &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37038      &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37039      &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37040      &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37041      &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37042      &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37043      &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37044      &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37045      &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37046      &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37047      &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37048       DATA (XUDF_L(K),K= 1027, 1140) /
37049      &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37050      &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37051      &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37052      &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37053      &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37054      &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37055      &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37056      &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37057      &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37058      &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37059      &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37060      &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37061      &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37062      &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37063      &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37064      &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37065      &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37066      &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37067      &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37068       DATA (XUDF_L(K),K= 1141, 1254) /
37069      &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37070      &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37071      &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37072      &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37073      &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37074      &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37075      &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37076      &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37077      &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37078      &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37079      &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37080      &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37081      &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37082      &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37083      &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37084      &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37085      &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37086      &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37087      &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37088       DATA (XUDF_L(K),K= 1255, 1368) /
37089      &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37090      &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37091      &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37092      &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37093      &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37094      &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37095      &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37096      &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37097      &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37098      &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37099      &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37100      &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37101      &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37102      &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37103      &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37104      &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37105      &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37106      &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37107      &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37108       DATA (XUDF_L(K),K= 1369, 1482) /
37109      &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37110      &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37111      &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37112      &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37113      &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37114      &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37115      &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37116      &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37117      &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37118      &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37119      &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37120      &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37121      &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37122      &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37123      &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37124      &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37125      &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37126      &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37127      &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37128       DATA (XUDF_L(K),K= 1483, 1596) /
37129      &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37130      &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37131      &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37132      &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37133      &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37134      &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37135      &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37136      &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37137      &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37138      &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37139      &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37140      &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37141      &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37142      &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37143      &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37144      &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37145      &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37146      &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37147      &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37148       DATA (XUDF_L(K),K= 1597, 1710) /
37149      &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37150      &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37151      &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37152      &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37153      &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37154      &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37155      &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37156      &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37157      &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37158      &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37159      &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37160      &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37161      &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37162      &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37163      &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37164      &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37165      &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37166      &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37167      &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37168       DATA (XUDF_L(K),K= 1711, 1824) /
37169      &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37170      &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37171      &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37172      &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37173      &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37174      &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37175      &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37176      &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37177      &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37178      &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37179      &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37180      &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37181      &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37182      &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37183      &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37184      &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37185      &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37186      &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37187      &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37188       DATA (XUDF_L(K),K= 1825, 1836) /
37189      &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37190      &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37191       DATA (XSF_L(K),K=    1,  114) /
37192      &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37193      &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37194      &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37195      &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37196      &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37197      &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37198      &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37199      &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37200      &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37201      &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37202      &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37203      &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37204      &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37205      &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37206      &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37207      &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37208      &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37209      &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37210      &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37211       DATA (XSF_L(K),K=  115,  228) /
37212      &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37213      &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37214      &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37215      &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37216      &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37217      &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37218      &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37219      &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37220      &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37221      &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37222      &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37223      &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37224      &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37225      &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37226      &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37227      &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37228      &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37229      &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37230      &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37231       DATA (XSF_L(K),K=  229,  342) /
37232      &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37233      &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37234      &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37235      &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37236      &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37237      &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37238      &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37239      &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37240      &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37241      &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37242      &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37243      &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37244      &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37245      &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37246      &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37247      &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37248      &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37249      &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37250      &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37251       DATA (XSF_L(K),K=  343,  456) /
37252      &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37253      &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37254      &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37255      &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37256      &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37257      &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37258      &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37259      &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37260      &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37261      &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37262      &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37263      &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37264      &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37265      &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37266      &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37267      &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37268      &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37269      &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37270      &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37271       DATA (XSF_L(K),K=  457,  570) /
37272      &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37273      &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37274      &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37275      &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37276      &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37277      &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37278      &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37279      &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37280      &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37281      &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37282      &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37283      &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37284      &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37285      &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37286      &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37287      &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37288      &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37289      &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37290      &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37291       DATA (XSF_L(K),K=  571,  684) /
37292      &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37293      &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37294      &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37295      &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37296      &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37297      &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37298      &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37299      &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37300      &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37301      &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37302      &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37303      &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37304      &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37305      &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37306      &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37307      &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37308      &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37309      &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37310      &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37311       DATA (XSF_L(K),K=  685,  798) /
37312      &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37313      &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37314      &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37315      &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37316      &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37317      &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37318      &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37319      &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37320      &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37321      &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37322      &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37323      &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37324      &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37325      &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37326      &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37327      &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37328      &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37329      &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37330      &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37331       DATA (XSF_L(K),K=  799,  912) /
37332      &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37333      &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37334      &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37335      &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37336      &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37337      &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37338      &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37339      &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37340      &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37341      &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37342      &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37343      &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37344      &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37345      &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37346      &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37347      &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37348      &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37349      &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37350      &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37351       DATA (XSF_L(K),K=  913, 1026) /
37352      &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37353      &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37354      &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37355      &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37356      &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37357      &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37358      &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37359      &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37360      &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37361      &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37362      &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37363      &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37364      &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37365      &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37366      &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37367      &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37368      &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37369      &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37370      &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37371       DATA (XSF_L(K),K= 1027, 1140) /
37372      &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37373      &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37374      &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37375      &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37376      &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37377      &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37378      &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37379      &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37380      &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37381      &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37382      &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37383      &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37384      &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37385      &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37386      &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37387      &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37388      &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37389      &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37390      &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37391       DATA (XSF_L(K),K= 1141, 1254) /
37392      &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37393      &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37394      &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37395      &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37396      &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37397      &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37398      &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37399      &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37400      &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37401      &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37402      &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37403      &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37404      &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37405      &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37406      &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37407      &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37408      &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37409      &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37410      &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37411       DATA (XSF_L(K),K= 1255, 1368) /
37412      &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37413      &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37414      &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37415      &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37416      &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37417      &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37418      &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37419      &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37420      &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37421      &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37422      &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37423      &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37424      &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37425      &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37426      &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37427      &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37428      &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37429      &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37430      &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37431       DATA (XSF_L(K),K= 1369, 1482) /
37432      &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37433      &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37434      &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37435      &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37436      &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37437      &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37438      &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37439      &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37440      &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37441      &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37442      &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37443      &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37444      &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37445      &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37446      &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37447      &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37448      &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37449      &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37450      &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37451       DATA (XSF_L(K),K= 1483, 1596) /
37452      &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37453      &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37454      &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37455      &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37456      &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37457      &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37458      &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37459      &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37460      &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37461      &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37462      &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37463      &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37464      &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37465      &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37466      &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37467      &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37468      &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37469      &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37470      &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37471       DATA (XSF_L(K),K= 1597, 1710) /
37472      &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37473      &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37474      &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37475      &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37476      &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37477      &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37478      &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37479      &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37480      &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37481      &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37482      &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37483      &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37484      &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37485      &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37486      &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37487      &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37488      &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37489      &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37490      &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37491       DATA (XSF_L(K),K= 1711, 1824) /
37492      &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37493      &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37494      &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37495      &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37496      &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37497      &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37498      &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37499      &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37500      &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37501      &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37502      &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37503      &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37504      &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37505      &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37506      &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37507      &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37508      &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37509      &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37510      &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37511       DATA (XSF_L(K),K= 1825, 1836) /
37512      &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37513      &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37514       DATA (XGF_L(K),K=    1,  114) /
37515      &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37516      &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37517      &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37518      &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37519      &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37520      &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37521      &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37522      &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37523      &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37524      &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37525      &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37526      &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37527      &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37528      &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37529      &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37530      &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37531      &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37532      &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37533      &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37534       DATA (XGF_L(K),K=  115,  228) /
37535      &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37536      &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37537      &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37538      &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37539      &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37540      &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37541      &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37542      &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37543      &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37544      &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37545      &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37546      &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37547      &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37548      &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37549      &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37550      &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37551      &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37552      &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37553      &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37554       DATA (XGF_L(K),K=  229,  342) /
37555      &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37556      &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37557      &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37558      &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37559      &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37560      &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37561      &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37562      &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37563      &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37564      &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37565      &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37566      &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37567      &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37568      &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37569      &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37570      &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37571      &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37572      &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37573      &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37574       DATA (XGF_L(K),K=  343,  456) /
37575      &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37576      &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37577      &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37578      &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
37579      &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
37580      &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
37581      &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
37582      &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
37583      &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
37584      &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
37585      &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
37586      &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
37587      &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
37588      &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
37589      &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
37590      &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
37591      &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
37592      &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
37593      &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
37594       DATA (XGF_L(K),K=  457,  570) /
37595      &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
37596      &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
37597      &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
37598      &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
37599      &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
37600      &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
37601      &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
37602      &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
37603      &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
37604      &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
37605      &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
37606      &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
37607      &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
37608      &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
37609      &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
37610      &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
37611      &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
37612      &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
37613      &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
37614       DATA (XGF_L(K),K=  571,  684) /
37615      &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
37616      &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
37617      &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
37618      &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
37619      &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
37620      &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
37621      &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
37622      &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
37623      &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
37624      &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
37625      &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
37626      &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
37627      &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
37628      &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
37629      &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
37630      &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
37631      &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
37632      &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
37633      &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
37634       DATA (XGF_L(K),K=  685,  798) /
37635      &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
37636      &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
37637      &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
37638      &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
37639      &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
37640      &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
37641      &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
37642      &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
37643      &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
37644      &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
37645      &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
37646      &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
37647      &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
37648      &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
37649      &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
37650      &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
37651      &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
37652      &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
37653      &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
37654       DATA (XGF_L(K),K=  799,  912) /
37655      &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
37656      &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
37657      &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
37658      &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
37659      &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
37660      &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
37661      &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
37662      &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
37663      &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
37664      &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
37665      &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
37666      &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
37667      &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
37668      &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
37669      &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
37670      &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
37671      &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
37672      &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
37673      &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
37674       DATA (XGF_L(K),K=  913, 1026) /
37675      &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
37676      &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
37677      &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
37678      &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
37679      &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
37680      &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
37681      &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
37682      &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
37683      &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
37684      &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
37685      &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
37686      &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
37687      &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
37688      &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
37689      &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
37690      &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
37691      &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
37692      &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
37693      &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
37694       DATA (XGF_L(K),K= 1027, 1140) /
37695      &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
37696      &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
37697      &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
37698      &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
37699      &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
37700      &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
37701      &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
37702      &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
37703      &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
37704      &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
37705      &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
37706      &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
37707      &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
37708      &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
37709      &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
37710      &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
37711      &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
37712      &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
37713      &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
37714       DATA (XGF_L(K),K= 1141, 1254) /
37715      &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
37716      &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
37717      &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
37718      &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
37719      &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
37720      &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
37721      &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
37722      &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
37723      &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
37724      &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
37725      &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
37726      &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
37727      &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
37728      &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
37729      &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
37730      &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
37731      &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
37732      &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
37733      &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
37734       DATA (XGF_L(K),K= 1255, 1368) /
37735      &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
37736      &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
37737      &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
37738      &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
37739      &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
37740      &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
37741      &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
37742      &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
37743      &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
37744      &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
37745      &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
37746      &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
37747      &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
37748      &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
37749      &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
37750      &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
37751      &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
37752      &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
37753      &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
37754       DATA (XGF_L(K),K= 1369, 1482) /
37755      &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
37756      &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
37757      &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
37758      &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
37759      &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
37760      &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
37761      &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
37762      &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
37763      &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
37764      &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
37765      &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
37766      &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
37767      &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
37768      &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
37769      &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
37770      &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
37771      &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
37772      &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
37773      &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
37774       DATA (XGF_L(K),K= 1483, 1596) /
37775      &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
37776      &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
37777      &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
37778      &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
37779      &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
37780      &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
37781      &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
37782      &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
37783      &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
37784      &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
37785      &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
37786      &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
37787      &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
37788      &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
37789      &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
37790      &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
37791      &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
37792      &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
37793      &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
37794       DATA (XGF_L(K),K= 1597, 1710) /
37795      &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
37796      &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
37797      &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
37798      &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
37799      &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
37800      &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
37801      &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
37802      &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
37803      &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
37804      &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
37805      &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
37806      &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
37807      &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
37808      &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
37809      &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
37810      &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
37811      &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
37812      &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
37813      &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
37814       DATA (XGF_L(K),K= 1711, 1824) /
37815      &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
37816      &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
37817      &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
37818      &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
37819      &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
37820      &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
37821      &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
37822      &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
37823      &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
37824      &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
37825      &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
37826      &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
37827      &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
37828      &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
37829      &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
37830      &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
37831      &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
37832      &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
37833      &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
37834       DATA (XGF_L(K),K= 1825, 1836) /
37835      &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
37836      &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
37837
37838 *
37839       X = Xinp
37840 *...CHECK OF X AND Q2 VALUES :
37841       IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37842 *        WRITE(LO,91) X
37843   91     FORMAT (2X,'GRV98: x out of range',1p,E12.4)
37844          X = 0.99D-9
37845 *        STOP
37846       ENDIF
37847
37848       Q2 = Q2inp
37849       IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37850 *        WRITE(LO,92) Q2
37851   92     FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
37852          Q2 = 0.99E6
37853 *        STOP
37854       ENDIF
37855
37856 *
37857 *...INTERPOLATION :
37858       NA(1) = NX
37859       NA(2) = NQ
37860       XT(1) = DLOG(X)
37861       XT(2) = DLOG(Q2)
37862       X1 = 1.- X
37863       XV = X**0.5
37864       XS = X**(-0.2)
37865       UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37866       DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37867       DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37868       UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37869       US = 0.5 * (UD - DE)
37870       DS = 0.5 * (UD + DE)
37871       SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF)  * X1**7 * XS
37872       GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF)  * X1**5 * XS
37873
37874       END
37875
37876 *$ CREATE PHO_DOR98SC.FOR
37877 *COPY PHO_DOR98SC
37878 CDECK  ID>, PHO_DOR98SC
37879       SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
37880 C***********************************************************************
37881 C
37882 C   GRV98 parton densities, leading order set
37883 C
37884 C                  For a detailed explanation see
37885 C                   M. Glueck, E. Reya, A. Vogt :
37886 C        hep-ph/9806404  =  DO-TH 98/07  =  WUE-ITP-98-019
37887 C                  (To appear in Eur. Phys. J. C)
37888 C
37889 C   interpolation routine based on the original GRV98PA routine,
37890 C   adapted to define interpolation table as DATA statements
37891 C
37892 C                                                   (R.Engel, 09/98)
37893 C
37894 C   CAUTION: this is a version with gluon shadowing corrections
37895 C                                                   (R.Engel, 09/99)
37896 C
37897 C
37898 C   INPUT:   X  =  Bjorken-x        (between  1.E-9 and 1.)
37899 C            Q2 =  scale in GeV**2  (between  0.8 and 1.E6)
37900 C
37901 C   OUTPUT:  UV = u - u(bar),  DV = d - d(bar),  US = u(bar),
37902 C            DS = d(bar),  SS = s = s(bar),  GL = gluon.
37903 C            Always x times the distribution is returned.
37904 C
37905 C******************************************************i****************
37906       IMPLICIT DOUBLE PRECISION (A-H, O-Z)
37907       SAVE
37908
37909 C  input/output channels
37910       INTEGER LI,LO
37911       COMMON /POINOU/ LI,LO
37912
37913       PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
37914       DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
37915      1          XSF(NX,NQ), XGF(NX,NQ),
37916      2          XT(NARG), NA(NARG), ARRF(NX+NQ)
37917
37918       DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
37919      &  XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
37920
37921       EQUIVALENCE (XUVF(1,1),XUVF_L(1))
37922       EQUIVALENCE (XDVF(1,1),XDVF_L(1))
37923       EQUIVALENCE (XDEF(1,1),XDEF_L(1))
37924       EQUIVALENCE (XUDF(1,1),XUDF_L(1))
37925       EQUIVALENCE (XSF(1,1),XSF_L(1))
37926       EQUIVALENCE (XGF(1,1),XGF_L(1))
37927
37928 *#################### data statements for shadowed LO PDF ##############
37929 C  ... deleted ...
37930 *#######################################################################
37931
37932       X = Xinp
37933 *...CHECK OF X AND Q2 VALUES :
37934       IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37935 *        WRITE(LO,91) X
37936   91     FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
37937          X = 0.99D-9
37938 *        STOP
37939       ENDIF
37940
37941       Q2 = Q2inp
37942       IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37943 *        WRITE(LO,92) Q2
37944   92     FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
37945          Q2 = 0.99E6
37946 *        STOP
37947       ENDIF
37948
37949 *
37950 *...INTERPOLATION :
37951       NA(1) = NX
37952       NA(2) = NQ
37953       XT(1) = DLOG(X)
37954       XT(2) = DLOG(Q2)
37955       X1 = 1.- X
37956       XV = X**0.5
37957       XS = X**(-0.2)
37958       UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37959       DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37960       DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37961       UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37962       US = 0.5 * (UD - DE)
37963       DS = 0.5 * (UD + DE)
37964       SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF)  * X1**7 * XS
37965       GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF)  * X1**5 * XS
37966
37967       END
37968
37969 *$ CREATE PHO_DOR94LO.FOR
37970 *COPY PHO_DOR94LO
37971 CDECK  ID>, PHO_DOR94LO
37972 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
37973 *                                                                 *
37974 *    G R V  -  P R O T O N  - P A R A M E T R I Z A T I O N S     *
37975 *                                                                 *
37976 *                         1994 UPDATE                             *
37977 *                                                                 *
37978 *                 FOR A DETAILED EXPLANATION SEE                  *
37979 *                   M. GLUECK, E.REYA, A.VOGT :                   *
37980 *                   DO-TH 94/24  =  DESY 94-206                   *
37981 *                    (TO APPEAR IN Z. PHYS. C)                    *
37982 *                                                                 *
37983 *   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
37984 *        Q**2 / GEV**2  BETWEEN   0.4   AND  1.E6                 *
37985 *             X         BETWEEN  1.E-5  AND   1.                  *
37986 *   LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION   *
37987 *   IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT.              *
37988 *                                                                 *
37989 *   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
37990 *                   M(C)  =  1.5,  M(B)  =  4.5                   *
37991 *   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
37992 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
37993 *             LAMBDA(5)  =  0.153,                                *
37994 *      NLO :  LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
37995 *             LAMBDA(5)  =  0.131.                                *
37996 *   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
37997 *   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
37998 *   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
37999 *   IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991   *
38000 *   GRV PARAMETRIZATION.                                          *
38001 *                                                                 *
38002 *   NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME    *
38003 *   (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI),  *
38004 *   THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO".   *
38005 *                                                                 *
38006 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38007 *
38008 *...INPUT PARAMETERS :
38009 *
38010 *    X   = MOMENTUM FRACTION
38011 *    Q2  = SCALE Q**2 IN GEV**2
38012 *
38013 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
38014 *
38015 *    UV  = U(VAL) = U - U(BAR)
38016 *    DV  = D(VAL) = D - D(BAR)
38017 *    DEL = D(BAR) - U(BAR)
38018 *    UDB = U(BAR) + D(BAR)
38019 *    SB  = S = S(BAR)
38020 *    GL  = GLUON
38021 *
38022 *...LO PARAMETRIZATION :
38023 *
38024       SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38025       IMPLICIT DOUBLE PRECISION (A - Z)
38026       SAVE
38027
38028        MU2  = 0.23
38029        LAM2 = 0.2322 * 0.2322
38030        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38031        DS = SQRT (S)
38032        S2 = S * S
38033        S3 = S2 * S
38034 *...UV :
38035        NU  =  2.284 + 0.802 * S + 0.055 * S2
38036        AKU =  0.590 - 0.024 * S
38037        BKU =  0.131 + 0.063 * S
38038        AU  = -0.449 - 0.138 * S - 0.076 * S2
38039        BU  =  0.213 + 2.669 * S - 0.728 * S2
38040        CU  =  8.854 - 9.135 * S + 1.979 * S2
38041        DU  =  2.997 + 0.753 * S - 0.076 * S2
38042        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38043 *...DV :
38044        ND  =  0.371 + 0.083 * S + 0.039 * S2
38045        AKD =  0.376
38046        BKD =  0.486 + 0.062 * S
38047        AD  = -0.509 + 3.310 * S - 1.248 * S2
38048        BD  =  12.41 - 10.52 * S + 2.267 * S2
38049        CD  =  6.373 - 6.208 * S + 1.418 * S2
38050        DD  =  3.691 + 0.799 * S - 0.071 * S2
38051        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38052 *...DEL :
38053        NE  =  0.082 + 0.014 * S + 0.008 * S2
38054        AKE =  0.409 - 0.005 * S
38055        BKE =  0.799 + 0.071 * S
38056        AE  = -38.07 + 36.13 * S - 0.656 * S2
38057        BE  =  90.31 - 74.15 * S + 7.645 * S2
38058        CE  =  0.0
38059        DE  =  7.486 + 1.217 * S - 0.159 * S2
38060        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38061 *...UDB :
38062        ALX =  1.451
38063        BEX =  0.271
38064        AKX =  0.410 - 0.232 * S
38065        BKX =  0.534 - 0.457 * S
38066        AGX =  0.890 - 0.140 * S
38067        BGX = -0.981
38068        CX  =  0.320 + 0.683 * S
38069        DX  =  4.752 + 1.164 * S + 0.286 * S2
38070        EX  =  4.119 + 1.713 * S
38071        ESX =  0.682 + 2.978 * S
38072        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38073 *...SB :
38074        ALS =  0.914
38075        BES =  0.577
38076        AKS =  1.798 - 0.596 * S
38077        AS  = -5.548 + 3.669 * DS - 0.616 * S
38078        BS  =  18.92 - 16.73 * DS + 5.168 * S
38079        DST =  6.379 - 0.350 * S  + 0.142 * S2
38080        EST =  3.981 + 1.638 * S
38081        ESS =  6.402
38082        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38083 *...GL :
38084        ALG =  0.524
38085        BEG =  1.088
38086        AKG =  1.742 - 0.930 * S
38087        BKG =        - 0.399 * S2
38088        AG  =  7.486 - 2.185 * S
38089        BG  =  16.69 - 22.74 * S  + 5.779 * S2
38090        CG  = -25.59 + 29.71 * S  - 7.296 * S2
38091        DG  =  2.792 + 2.215 * S  + 0.422 * S2 - 0.104 * S3
38092        EG  =  0.807 + 2.005 * S
38093        ESG =  3.841 + 0.316 * S
38094        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38095
38096        END
38097
38098 *
38099 *...NLO PARAMETRIZATION (MS(BAR)) :
38100 *
38101 *$ CREATE PHO_DOR94HO.FOR
38102 *COPY PHO_DOR94HO
38103 CDECK  ID>, PHO_DOR94HO
38104       SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38105       IMPLICIT DOUBLE PRECISION (A - Z)
38106       SAVE
38107
38108        MU2  = 0.34
38109        LAM2 = 0.248 * 0.248
38110        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38111        DS = SQRT (S)
38112        S2 = S * S
38113        S3 = S2 * S
38114 *...UV :
38115        NU  =  1.304 + 0.863 * S
38116        AKU =  0.558 - 0.020 * S
38117        BKU =          0.183 * S
38118        AU  = -0.113 + 0.283 * S - 0.321 * S2
38119        BU  =  6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38120        CU  =  7.771 - 10.09 * S + 2.630 * S2
38121        DU  =  3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38122        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38123 *...DV :
38124        ND  =  0.102 - 0.017 * S + 0.005 * S2
38125        AKD =  0.270 - 0.019 * S
38126        BKD =  0.260
38127        AD  =  2.393 + 6.228 * S - 0.881 * S2
38128        BD  =  46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38129        CD  =  17.83 - 53.47 * S + 21.24 * S2
38130        DD  =  4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38131        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38132 *...DEL :
38133        NE  =  0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38134        AKE =  0.409 - 0.007 * S
38135        BKE =  0.782 + 0.082 * S
38136        AE  = -29.65 + 26.49 * S + 5.429 * S2
38137        BE  =  90.20 - 74.97 * S + 4.526 * S2
38138        CE  =  0.0
38139        DE  =  8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38140        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38141 *...UDB :
38142        ALX =  0.877
38143        BEX =  0.561
38144        AKX =  0.275
38145        BKX =  0.0
38146        AGX =  0.997
38147        BGX =  3.210 - 1.866 * S
38148        CX  =  7.300
38149        DX  =  9.010 + 0.896 * DS + 0.222 * S2
38150        EX  =  3.077 + 1.446 * S
38151        ESX =  3.173 - 2.445 * DS + 2.207 * S
38152        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38153 *...SB :
38154        ALS =  0.756
38155        BES =  0.216
38156        AKS =  1.690 + 0.650 * DS - 0.922 * S
38157        AS  = -4.329 + 1.131 * S
38158        BS  =  9.568 - 1.744 * S
38159        DST =  9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38160        EST =  3.031 + 1.639 * S
38161        ESS =  5.837 + 0.815 * S
38162        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38163 *...GL :
38164        ALG =  1.014
38165        BEG =  1.738
38166        AKG =  1.724 + 0.157 * S
38167        BKG =  0.800 + 1.016 * S
38168        AG  =  7.517 - 2.547 * S
38169        BG  =  34.09 - 52.21 * DS + 17.47 * S
38170        CG  =  4.039 + 1.491 * S
38171        DG  =  3.404 + 0.830 * S
38172        EG  = -1.112 + 3.438 * S  - 0.302 * S2
38173        ESG =  3.256 - 0.436 * S
38174        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38175
38176        END
38177
38178 *$ CREATE PHO_DOR94DI.FOR
38179 *COPY PHO_DOR94DI
38180 CDECK  ID>, PHO_DOR94DI
38181 *
38182 *...NLO PARAMETRIZATION (DIS) :
38183 *
38184       SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38185       IMPLICIT DOUBLE PRECISION (A - Z)
38186       SAVE
38187
38188        MU2  = 0.34
38189        LAM2 = 0.248 * 0.248
38190        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38191        DS = SQRT (S)
38192        S2 = S * S
38193        S3 = S2 * S
38194 *...UV :
38195        NU  =  2.484 + 0.116 * S + 0.093 * S2
38196        AKU =  0.563 - 0.025 * S
38197        BKU =  0.054 + 0.154 * S
38198        AU  = -0.326 - 0.058 * S - 0.135 * S2
38199        BU  = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38200        CU  =  11.52 - 12.99 * S + 3.161 * S2
38201        DU  =  2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38202        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38203 *...DV :
38204        ND  =  0.156 - 0.017 * S
38205        AKD =  0.299 - 0.022 * S
38206        BKD =  0.259 - 0.015 * S
38207        AD  =  3.445 + 1.278 * S + 0.326 * S2
38208        BD  = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38209        CD  =  55.45 - 69.92 * S + 20.78 * S2
38210        DD  =  3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38211        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38212 *...DEL :
38213        NE  =  0.099 + 0.019 * S + 0.002 * S2
38214        AKE =  0.419 - 0.013 * S
38215        BKE =  1.064 - 0.038 * S
38216        AE  = -44.00 + 98.70 * S - 14.79 * S2
38217        BE  =  28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38218        CE  =  84.57 - 108.8 * S + 31.52 * S2
38219        DE  =  7.469 + 2.480 * S - 0.866 * S2
38220        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38221 *...UDB :
38222        ALX =  1.215
38223        BEX =  0.466
38224        AKX =  0.326 + 0.150 * S
38225        BKX =  0.956 + 0.405 * S
38226        AGX =  0.272
38227        BGX =  3.794 - 2.359 * DS
38228        CX  =  2.014
38229        DX  =  7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38230        EX  =  3.049 + 1.597 * S
38231        ESX =  4.396 - 4.594 * DS + 3.268 * S
38232        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38233 *...SB :
38234        ALS =  0.175
38235        BES =  0.344
38236        AKS =  1.415 - 0.641 * DS
38237        AS  =  0.580 - 9.763 * DS + 6.795 * S  - 0.558 * S2
38238        BS  =  5.617 + 5.709 * DS - 3.972 * S
38239        DST =  13.78 - 9.581 * S  + 5.370 * S2 - 0.996 * S3
38240        EST =  4.546 + 0.372 * S2
38241        ESS =  5.053 - 1.070 * S  + 0.805 * S2
38242        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38243 *...GL :
38244        ALG =  1.258
38245        BEG =  1.846
38246        AKG =  2.423
38247        BKG =  2.427 + 1.311 * S  - 0.153 * S2
38248        AG  =  25.09 - 7.935 * S
38249        BG  = -14.84 - 124.3 * DS + 72.18 * S
38250        CG  =  590.3 - 173.8 * S
38251        DG  =  5.196 + 1.857 * S
38252        EG  = -1.648 + 3.988 * S  - 0.432 * S2
38253        ESG =  3.232 - 0.542 * S
38254        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38255
38256        END
38257
38258 *
38259 *...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38260 *
38261 *$ CREATE PHO_DOR94FV.FOR
38262 *COPY PHO_DOR94FV
38263 CDECK  ID>, PHO_DOR94FV
38264       DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38265       IMPLICIT DOUBLE PRECISION (A - Z)
38266       SAVE
38267
38268        DX = SQRT (X)
38269        PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38270
38271       END
38272
38273 *$ CREATE PHO_DOR94FW.FOR
38274 *COPY PHO_DOR94FW
38275 CDECK  ID>, PHO_DOR94FW
38276       DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38277      &                                      A,B,C,D,E,ES)
38278       IMPLICIT DOUBLE PRECISION (A - Z)
38279       SAVE
38280
38281       LX = LOG (1./X)
38282       PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38283      1     * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38284
38285       END
38286
38287 *$ CREATE PHO_DOR94FS.FOR
38288 *COPY PHO_DOR94FS
38289 CDECK  ID>, PHO_DOR94FS
38290       DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38291       IMPLICIT DOUBLE PRECISION (A - Z)
38292       SAVE
38293
38294       DX = SQRT (X)
38295       LX = LOG (1./X)
38296       PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38297      1      * DEXP (-E + SQRT (ES * S**BE * LX))
38298
38299       END
38300
38301 *$ CREATE PHO_DOR92LO.FOR
38302 *COPY PHO_DOR92LO
38303 CDECK  ID>, PHO_DOR92LO
38304 *
38305 *
38306 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38307 *                                                                 *
38308 *    G R V  -  P R O T O N  - P A R A M E T R I Z A T I O N S     *
38309 *                                                                 *
38310 *                 FOR A DETAILED EXPLANATION SEE :                *
38311 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07             *
38312 *                                                                 *
38313 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38314 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38315 *   / HO) AND  1.E8 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38316 *   REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG-   *
38317 *   LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT.  *
38318 *                                                                 *
38319 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38320 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38321 *                                                                 *
38322 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38323 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38324 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38325 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38326 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38327 *                                                                 *
38328 *   HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL.  *
38329 *                                                                 *
38330 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38331 C
38332       SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38333       IMPLICIT DOUBLE PRECISION (A - Z)
38334       SAVE
38335
38336        MU2  = 0.25
38337        LAM2 = 0.232 * 0.232
38338        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38339        S2 = S * S
38340        S3 = S2 * S
38341 C...X * (UV + DV) :
38342        NUD  = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38343        AKUD = 0.326
38344        AGUD = -1.97 +  6.74 * S -  1.96 * S2
38345        BUD  =  24.4 -  20.7 * S +  4.08 * S2
38346        DUD  =  2.86 +  0.70 * S -  0.02 * S2
38347        UDV  = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38348 C...X * DV :
38349        ND  = 0.579 + 0.283 * S + 0.047 * S2
38350        AKD = 0.523 - 0.015 * S
38351        AGD =  2.22 -  0.59 * S -  0.27 * S2
38352        BD  =  5.95 -  6.19 * S +  1.55 * S2
38353        DD  =  3.57 +  0.94 * S -  0.16 * S2
38354        DV  = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38355 C...X * G :
38356        ALG =  0.558
38357        BEG =  1.218
38358        AKG =   1.00 -  0.17 * S
38359        BKG =   0.0
38360        AGG =   0.0  + 4.879 * S - 1.383 * S2
38361        BGG =  25.92 - 28.97 * S + 5.596 * S2
38362        CG  = -25.69 + 23.68 * S - 1.975 * S2
38363        DG  =  2.537 + 1.718 * S + 0.353 * S2
38364        EG  =  0.595 + 2.138 * S
38365        ESG =  4.066
38366        GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38367 C...X * UBAR = X * DBAR :
38368        ALU =  1.396
38369        BEU =  1.331
38370        AKU =  0.412 - 0.171 * S
38371        BKU =  0.566 - 0.496 * S
38372        AGU =  0.363
38373        BGU = -1.196
38374        CU  =  1.029 + 1.785 * S - 0.459 * S2
38375        DU  =  4.696 + 2.109 * S
38376        EU  =  3.838 + 1.944 * S
38377        ESU =  2.845
38378        UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38379 C...X * SBAR = X * S :
38380        SS  =   0.0
38381        ALS =  0.803
38382        BES =  0.563
38383        AKS =  2.082 - 0.577 * S
38384        AGS = -3.055 + 1.024 * S **  0.67
38385        BS  =   27.4 -  20.0 * S ** 0.154
38386        DS  =   6.22
38387        EST =   4.33 + 1.408 * S
38388        ESS =   8.27 - 0.437 * S
38389        SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38390 C...X * CBAR = X * C :
38391        SC  =  0.888
38392        ALC =   1.01
38393        BEC =   0.37
38394        AKC =   0.0
38395        AGC =   0.0
38396        BC  =   4.24 - 0.804 * S
38397        DC  =   3.46 + 1.076 * S
38398        EC  =   4.61 + 1.490 * S
38399        ESC =  2.555 + 1.961 * S
38400        CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38401 C...X * BBAR = X * B :
38402        SBO =  1.351
38403        ALB =   1.00
38404        BEB =   0.51
38405        AKB =   0.0
38406        AGB =   0.0
38407        BBO =  1.848
38408        DB  =  2.929 + 1.396 * S
38409        EB  =   4.71 + 1.514 * S
38410        ESB =   4.02 + 1.239 * S
38411        BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38412
38413       END
38414
38415 *$ CREATE PHO_DOR92HO.FOR
38416 *COPY PHO_DOR92HO
38417 CDECK  ID>, PHO_DOR92HO
38418       SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38419       IMPLICIT DOUBLE PRECISION (A - Z)
38420       SAVE
38421
38422        MU2  = 0.3
38423        LAM2 = 0.248 * 0.248
38424        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38425        DS = SQRT (S)
38426        S2 = S * S
38427        S3 = S2 * S
38428 C...X * (UV + DV) :
38429        NUD  = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38430        AKUD = 0.285
38431        AGUD = -2.28 + 15.73 * S -  4.58 * S2
38432        BUD  =  56.7 -  53.6 * S + 11.21 * S2
38433        DUD  =  3.17 +  1.17 * S -  0.47 * S2 +  0.09 * S3
38434        UDV  = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38435 C...X * DV :
38436        ND  = 0.459 + 0.315 * DS + 0.515 * S
38437        AKD = 0.624              - 0.031 * S
38438        AGD =  8.13 -  6.77 * DS +  0.46 * S
38439        BD  =  6.59 - 12.83 * DS +  5.65 * S
38440        DD  =  3.98              +  1.04 * S  -  0.34 * S2
38441        DV  = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38442 C...X * G :
38443        ALG =  1.128
38444        BEG =  1.575
38445        AKG =  0.323 + 1.653 * S
38446        BKG =  0.811 + 2.044 * S
38447        AGG =   0.0  + 1.963 * S - 0.519 * S2
38448        BGG =  0.078 +  6.24 * S
38449        CG  =  30.77 - 24.19 * S
38450        DG  =  3.188 + 0.720 * S
38451        EG  = -0.881 + 2.687 * S
38452        ESG =  2.466
38453        GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38454 C...X * UBAR = X * DBAR :
38455        ALU =  0.594
38456        BEU =  0.614
38457        AKU =  0.636 - 0.084 * S
38458        BKU =   0.0
38459        AGU =  1.121 - 0.193 * S
38460        BGU =  0.751 - 0.785 * S
38461        CU  =   8.57 - 1.763 * S
38462        DU  =  10.22 + 0.668 * S
38463        EU  =  3.784 + 1.280 * S
38464        ESU =  1.808 + 0.980 * S
38465        UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38466 C...X * SBAR = X * S :
38467        SS  =   0.0
38468        ALS =  0.756
38469        BES =  0.101
38470        AKS =  2.942 - 1.016 * S
38471        AGS =  -4.60 + 1.167 * S
38472        BS  =   9.31 - 1.324 * S
38473        DS  =  11.49 - 1.198 * S + 0.053 * S2
38474        EST =  2.630 + 1.729 * S
38475        ESS =   8.12
38476        SB  = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38477 C...X * CBAR = X * C :
38478        SC  =  0.820
38479        ALC =   0.98
38480        BEC =   0.0
38481        AKC = -0.625 - 0.523 * S
38482        AGC =   0.0
38483        BC  =  1.896 + 1.616 * S
38484        DC  =   4.12 + 0.683 * S
38485        EC  =   4.36 + 1.328 * S
38486        ESC =  0.677 + 0.679 * S
38487        CB  = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38488 C...X * BBAR = X * B :
38489        SBO =  1.297
38490        ALB =   0.99
38491        BEB =   0.0
38492        AKB =   0.0  - 0.193 * S
38493        AGB =   0.0
38494        BBO =   0.0
38495        DB  =  3.447 + 0.927 * S
38496        EB  =   4.68 + 1.259 * S
38497        ESB =  1.892 + 2.199 * S
38498        BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38499
38500       END
38501
38502 *$ CREATE PHO_DOR92FV.FOR
38503 *COPY PHO_DOR92FV
38504 CDECK  ID>, PHO_DOR92FV
38505       DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38506       IMPLICIT DOUBLE PRECISION (A - Z)
38507       SAVE
38508        DX = SQRT (X)
38509        PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38510
38511       END
38512
38513 *$ CREATE PHO_DOR92FW.FOR
38514 *COPY PHO_DOR92FW
38515 CDECK  ID>, PHO_DOR92FW
38516       DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38517      &                                      AL,BE,AK,BK,AG,BG,C,D,E,ES)
38518       IMPLICIT DOUBLE PRECISION (A - Z)
38519       SAVE
38520        LX = LOG (1./X)
38521        PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38522      1      * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38523
38524       END
38525
38526 *$ CREATE PHO_DOR92FS.FOR
38527 *COPY PHO_DOR92FS
38528 CDECK  ID>, PHO_DOR92FS
38529       DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38530       IMPLICIT DOUBLE PRECISION (A - Z)
38531       SAVE
38532
38533        DX = SQRT (X)
38534        LX = LOG (1./X)
38535        IF (S .LE. ST) THEN
38536          PHO_DOR92FS = 0.D0
38537        ELSE
38538          PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38539      1          * EXP (-E + SQRT (ES * S**BE * LX))
38540        END IF
38541
38542       END
38543
38544 *$ CREATE PHO_DORPLO.FOR
38545 *COPY PHO_DORPLO
38546 CDECK  ID>, PHO_DORPLO
38547 *
38548 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38549 *                                                                 *
38550 *         G R V - P I O N - P A R A M E T R I Z A T I O N S       *
38551 *                                                                 *
38552 *                 FOR A DETAILED EXPLANATION SEE :                *
38553 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16             *
38554 *                                                                 *
38555 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38556 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38557 *   / HO) AND  1.E8 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38558 *   REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG-   *
38559 *   LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT.  *
38560 *                                                                 *
38561 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38562 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38563 *                                                                 *
38564 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38565 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38566 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38567 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38568 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38569 *                                                                 *
38570 *   HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL.  *
38571 *                                                                 *
38572 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38573 C
38574       SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38575       IMPLICIT DOUBLE PRECISION (A - Z)
38576       SAVE
38577
38578        MU2  = 0.25
38579        LAM2 = 0.232 * 0.232
38580        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38581        DS = SQRT (S)
38582        S2 = S * S
38583 C...X * VALENCE :
38584        NV  =  0.519 + 0.180 * S - 0.011 * S2
38585        AKV =  0.499 - 0.027 * S
38586        AGV =  0.381 - 0.419 * S
38587        DV  =  0.367 + 0.563 * S
38588        VAP =  PHO_DORFVP (X, NV, AKV, AGV, DV)
38589 C...X * GLUON :
38590        ALG =  0.599
38591        BEG =  1.263
38592        AKG =  0.482 + 0.341 * DS
38593        BKG =   0.0
38594        AGG =  0.678 + 0.877 * S  - 0.175 * S2
38595        BGG =  0.338 - 1.597 * S
38596        CG  =   0.0  - 0.233 * S  + 0.406 * S2
38597        DG  =  0.390 + 1.053 * S
38598        EG  =  0.618 + 2.070 * S
38599        ESG =  3.676
38600        GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38601 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38602        SL  =   0.0
38603        ALS =   0.55
38604        BES =   0.56
38605        AKS =  2.538 - 0.763 * S
38606        AGS = -0.748
38607        BS  =  0.313 + 0.935 * S
38608        DS  =  3.359
38609        EST =  4.433 + 1.301 * S
38610        ESS =   9.30 - 0.887 * S
38611        QBP =  PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38612 C...X * CBAR = X * C :
38613        SC  =  0.888
38614        ALC =   1.02
38615        BEC =   0.39
38616        AKC =   0.0
38617        AGC =   0.0
38618        BC  =  1.008
38619        DC  =  1.208 + 0.771 * S
38620        EC  =   4.40 + 1.493 * S
38621        ESC =  2.032 + 1.901 * S
38622        CBP =  PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38623 C...X * BBAR = X * B :
38624        SBO =  1.351
38625        ALB =   1.03
38626        BEB =   0.39
38627        AKB =   0.0
38628        AGB =   0.0
38629        BBO =   0.0
38630        DB  =  0.697 + 0.855 * S
38631        EB  =   4.51 + 1.490 * S
38632        ESB =  3.056 + 1.694 * S
38633        BBP =  PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38634
38635        END
38636
38637 *$ CREATE PHO_DORPHO.FOR
38638 *COPY PHO_DORPHO
38639 CDECK  ID>, PHO_DORPHO
38640       SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38641       IMPLICIT DOUBLE PRECISION (A - Z)
38642       SAVE
38643
38644        MU2  = 0.3
38645        LAM2 = 0.248 * 0.248
38646        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38647        DS = SQRT (S)
38648        S2 = S * S
38649 C...X * VALENCE :
38650        NV  =  0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
38651        AKV =  0.505 - 0.033 * S
38652        AGV =  0.748 - 0.669 * DS - 0.133 * S
38653        DV  =  0.365 + 0.197 * DS + 0.394 * S
38654        VAP =  PHO_DORFVP (X, NV, AKV, AGV, DV)
38655 C...X * GLUON :
38656        ALG =  1.096
38657        BEG =  1.371
38658        AKG =  0.437 - 0.689 * DS
38659        BKG = -0.631
38660        AGG =  1.324 - 0.441 * DS - 0.130 * S
38661        BGG = -0.955 + 0.259 * S
38662        CG  =  1.075 - 0.302 * S
38663        DG  =  1.158 + 1.229 * S
38664        EG  =   0.0  + 2.510 * S
38665        ESG =  2.604 + 0.165 * S
38666        GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38667 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38668        SL  =   0.0
38669        ALS =   0.85
38670        BES =   0.96
38671        AKS = -0.350 + 0.806 * S
38672        AGS = -1.663
38673        BS  =  3.148
38674        DS  =  2.273 + 1.438 * S
38675        EST =  3.214 + 1.545 * S
38676        ESS =  1.341 + 1.938 * S
38677        QBP =  PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38678 C...X * CBAR = X * C :
38679        SC  =  0.820
38680        ALC =   0.98
38681        BEC =   0.0
38682        AKC =   0.0  - 0.457 * S
38683        AGC =   0.0
38684        BC  =  -1.00 +  1.40 * S
38685        DC  =  1.318 + 0.584 * S
38686        EC  =   4.45 + 1.235 * S
38687        ESC =  1.496 + 1.010 * S
38688        CBP =  PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38689 C...X * BBAR = X * B :
38690        SBO =  1.297
38691        ALB =   0.99
38692        BEB =   0.0
38693        AKB =   0.0  - 0.172 * S
38694        AGB =   0.0
38695        BBO =   0.0
38696        DB  =  1.447 + 0.485 * S
38697        EB  =   4.79 + 1.164 * S
38698        ESB =  1.724 + 2.121 * S
38699        BBP =  PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38700
38701       END
38702
38703 *$ CREATE PHO_DORFVP.FOR
38704 *COPY PHO_DORFVP
38705 CDECK  ID>, PHO_DORFVP
38706       DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
38707       IMPLICIT DOUBLE PRECISION (A - Z)
38708       SAVE
38709
38710        DX = SQRT (X)
38711        PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
38712
38713       END
38714
38715 *$ CREATE PHO_DORFGP.FOR
38716 *COPY PHO_DORFGP
38717 CDECK  ID>, PHO_DORFGP
38718       DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
38719      &                                    BG,C,D,E,ES)
38720       IMPLICIT DOUBLE PRECISION (A - Z)
38721       SAVE
38722
38723        DX = SQRT (X)
38724        LX = LOG (1./X)
38725        PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
38726      1       * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38727
38728       END
38729
38730 *$ CREATE PHO_DORFQP.FOR
38731 *COPY PHO_DORFQP
38732 CDECK  ID>, PHO_DORFQP
38733       DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38734       IMPLICIT DOUBLE PRECISION (A - Z)
38735       SAVE
38736
38737        DX = SQRT (X)
38738        LX = LOG (1./X)
38739        IF (S .LE. ST) THEN
38740           PHO_DORFQP = 0.0
38741        ELSE
38742           PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38743      1           * EXP (-E + SQRT (ES * S**BE * LX))
38744        END IF
38745
38746       END
38747
38748 *$ CREATE PHO_DORGLO.FOR
38749 *COPY PHO_DORGLO
38750 CDECK  ID>, PHO_DORGLO
38751 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38752 *                                                                 *
38753 *      G R V - P H O T O N - P A R A M E T R I Z A T I O N S      *
38754 *                                                                 *
38755 *                 FOR A DETAILED EXPLANATION SEE :                *
38756 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31             *
38757 *                                                                 *
38758 *    THE OUTPUT IS ALWAYS   1./ ALPHA(EM) * X * PARTON DENSITY    *
38759 *                                                                 *
38760 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38761 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38762 *   / HO) AND  1.E6 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38763 *                                                                 *
38764 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38765 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38766 *                                                                 *
38767 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38768 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38769 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38770 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38771 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38772 *                                                                 *
38773 *      HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE :     *
38774 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26             *
38775 *                                                                 *
38776 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38777 C
38778       SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
38779       IMPLICIT DOUBLE PRECISION (A - Z)
38780       SAVE
38781
38782        MU2  = 0.25
38783        LAM2 = 0.232 * 0.232
38784        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38785        SS = SQRT (S)
38786        S2 = S * S
38787 C...X * U = X * UBAR :
38788        AL =  1.717
38789        BE =  0.641
38790        AK =  0.500 - 0.176 * S
38791        BK = 15.00  - 5.687 * SS - 0.552 * S2
38792        AG =  0.235 + 0.046 * SS
38793        BG =  0.082 - 0.051 * S  + 0.168 * S2
38794        C  =   0.0  + 0.459 * S
38795        D  =  0.354 - 0.061 * S
38796        E  =  4.899 + 1.678 * S
38797        ES =  2.046 + 1.389 * S
38798        UL =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38799 C...X * D = X * DBAR :
38800        AL =  1.549
38801        BE =  0.782
38802        AK =  0.496 + 0.026 * S
38803        BK =  0.685 - 0.580 * SS + 0.608 * S2
38804        AG =  0.233 + 0.302 * S
38805        BG =   0.0  - 0.818 * S  + 0.198 * S2
38806        C  =  0.114 + 0.154 * S
38807        D  =  0.405 - 0.195 * S  + 0.046 * S2
38808        E  =  4.807 + 1.226 * S
38809        ES =  2.166 + 0.664 * S
38810        DL  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38811 C...X * G :
38812        AL =  0.676
38813        BE =  1.089
38814        AK =  0.462 - 0.524 * SS
38815        BK =  5.451              - 0.804 * S2
38816        AG =  0.535 - 0.504 * SS + 0.288 * S2
38817        BG =  0.364 - 0.520 * S
38818        C  = -0.323              + 0.115 * S2
38819        D  =  0.233 + 0.790 * S  - 0.139 * S2
38820        E  =  0.893 + 1.968 * S
38821        ES =  3.432 + 0.392 * S
38822        GL =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38823 C...X * S = X * SBAR :
38824        SF =   0.0
38825        AL =  1.609
38826        BE =  0.962
38827        AK =  0.470              - 0.099 * S2
38828        BK =  3.246
38829        AG =  0.121 - 0.068 * SS
38830        BG = -0.090 + 0.074 * S
38831        C  =  0.062 + 0.034 * S
38832        D  =   0.0  + 0.226 * S  - 0.060 * S2
38833        E  =  4.288 + 1.707 * S
38834        ES =  2.122 + 0.656 * S
38835        SL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38836 C...X * C = X * CBAR :
38837        SF =  0.888
38838        AL =  0.970
38839        BE =  0.545
38840        AK =  1.254 - 0.251 * S
38841        BK =  3.932              - 0.327 * S2
38842        AG =  0.658 + 0.202 * S
38843        BG = -0.699
38844        C  =  0.965
38845        D  =   0.0  + 0.141 * S  - 0.027 * S2
38846        E  =  4.911 + 0.969 * S
38847        ES =  2.796 + 0.952 * S
38848        CL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38849 C...X * B = X * BBAR :
38850        SF =  1.351
38851        AL =  1.016
38852        BE =  0.338
38853        AK =  1.961 - 0.370 * S
38854        BK =  0.923 + 0.119 * S
38855        AG =  0.815 + 0.207 * S
38856        BG = -2.275
38857        C  =  1.480
38858        D  = -0.223 + 0.173 * S
38859        E  =  5.426 + 0.623 * S
38860        ES =  3.819 + 0.901 * S
38861        BL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38862
38863        END
38864
38865 *$ CREATE PHO_DORGHO.FOR
38866 *COPY PHO_DORGHO
38867 CDECK  ID>, PHO_DORGHO
38868       SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
38869       IMPLICIT DOUBLE PRECISION (A - Z)
38870       SAVE
38871
38872        MU2  = 0.3
38873        LAM2 = 0.248 * 0.248
38874        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38875        SS = SQRT (S)
38876        S2 = S * S
38877 C...X * U = X * UBAR :
38878        AL =  0.583
38879        BE =  0.688
38880        AK =  0.449 - 0.025 * S  - 0.071 * S2
38881        BK =  5.060 - 1.116 * SS
38882        AG =  0.103
38883        BG =  0.319 + 0.422 * S
38884        C  =  1.508 + 4.792 * S  - 1.963 * S2
38885        D  =  1.075 + 0.222 * SS - 0.193 * S2
38886        E  =  4.147 + 1.131 * S
38887        ES =  1.661 + 0.874 * S
38888        UH =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38889 C...X * D = X * DBAR :
38890        AL =  0.591
38891        BE =  0.698
38892        AK =  0.442 - 0.132 * S  - 0.058 * S2
38893        BK =  5.437 - 1.916 * SS
38894        AG =  0.099
38895        BG =  0.311 - 0.059 * S
38896        C  =  0.800 + 0.078 * S  - 0.100 * S2
38897        D  =  0.862 + 0.294 * SS - 0.184 * S2
38898        E  =  4.202 + 1.352 * S
38899        ES =  1.841 + 0.990 * S
38900        DH  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38901 C...X * G :
38902        AL =  1.161
38903        BE =  1.591
38904        AK =  0.530 - 0.742 * SS + 0.025 * S2
38905        BK =  5.662
38906        AG =  0.533 - 0.281 * SS + 0.218 * S2
38907        BG =  0.025 - 0.518 * S  + 0.156 * S2
38908        C  = -0.282              + 0.209 * S2
38909        D  =  0.107 + 1.058 * S  - 0.218 * S2
38910        E  =   0.0  + 2.704 * S
38911        ES =  3.071 - 0.378 * S
38912        GH =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38913 C...X * S = X * SBAR :
38914        SF =   0.0
38915        AL =  0.635
38916        BE =  0.456
38917        AK =  1.770 - 0.735 * SS - 0.079 * S2
38918        BK =  3.832
38919        AG =  0.084 - 0.023 * S
38920        BG =  0.136
38921        C  =  2.119 - 0.942 * S  + 0.063 * S2
38922        D  =  1.271 + 0.076 * S  - 0.190 * S2
38923        E  =  4.604 + 0.737 * S
38924        ES =  1.641 + 0.976 * S
38925        SH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38926 C...X * C = X * CBAR :
38927        SF =  0.820
38928        AL =  0.926
38929        BE =  0.152
38930        AK =  1.142 - 0.175 * S
38931        BK =  3.276
38932        AG =  0.504 + 0.317 * S
38933        BG = -0.433
38934        C  =  3.334
38935        D  =  0.398 + 0.326 * S  - 0.107 * S2
38936        E  =  5.493 + 0.408 * S
38937        ES =  2.426 + 1.277 * S
38938        CH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38939 C...X * B = X * BBAR :
38940        SF =  1.297
38941        AL =  0.969
38942        BE =  0.266
38943        AK =  1.953 - 0.391 * S
38944        BK =  1.657 - 0.161 * S
38945        AG =  1.076 + 0.034 * S
38946        BG = -2.015
38947        C  =  1.662
38948        D  =  0.353 + 0.016 * S
38949        E  =  5.713 + 0.249 * S
38950        ES =  3.456 + 0.673 * S
38951        BH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38952
38953       END
38954
38955 *$ CREATE PHO_DORGH0.FOR
38956 *COPY PHO_DORGH0
38957 CDECK  ID>, PHO_DORGH0
38958       SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
38959       IMPLICIT DOUBLE PRECISION (A - Z)
38960       SAVE
38961
38962        MU2  = 0.3
38963        LAM2 = 0.248 * 0.248
38964        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38965        SS = SQRT (S)
38966        S2 = S * S
38967 C...X * U = X * UBAR :
38968        AL =  1.447
38969        BE =  0.848
38970        AK =  0.527 + 0.200 * S  - 0.107 * S2
38971        BK =  7.106 - 0.310 * SS - 0.786 * S2
38972        AG =  0.197 + 0.533 * S
38973        BG =  0.062 - 0.398 * S  + 0.109 * S2
38974        C  =          0.755 * S  - 0.112 * S2
38975        D  =  0.318 - 0.059 * S
38976        E  =  4.225 + 1.708 * S
38977        ES =  1.752 + 0.866 * S
38978        U0 =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38979 C...X * D = X * DBAR :
38980        AL =  1.424
38981        BE =  0.770
38982        AK =  0.500 + 0.067 * SS - 0.055 * S2
38983        BK =  0.376 - 0.453 * SS + 0.405 * S2
38984        AG =  0.156 + 0.184 * S
38985        BG =   0.0  - 0.528 * S  + 0.146 * S2
38986        C  =  0.121 + 0.092 * S
38987        D  =  0.379 - 0.301 * S  + 0.081 * S2
38988        E  =  4.346 + 1.638 * S
38989        ES =  1.645 + 1.016 * S
38990        D0  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38991 C...X * G :
38992        AL =  0.661
38993        BE =  0.793
38994        AK =  0.537 - 0.600 * SS
38995        BK =  6.389              - 0.953 * S2
38996        AG =  0.558 - 0.383 * SS + 0.261 * S2
38997        BG =   0.0  - 0.305 * S
38998        C  = -0.222              + 0.078 * S2
38999        D  =  0.153 + 0.978 * S  - 0.209 * S2
39000        E  =  1.429 + 1.772 * S
39001        ES =  3.331 + 0.806 * S
39002        G0 =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39003 C...X * S = X * SBAR :
39004        SF =   0.0
39005        AL =  1.578
39006        BE =  0.863
39007        AK =  0.622 + 0.332 * S  - 0.300 * S2
39008        BK =  2.469
39009        AG =  0.211 - 0.064 * SS - 0.018 * S2
39010        BG = -0.215 + 0.122 * S
39011        C  =  0.153
39012        D  =   0.0  + 0.253 * S  - 0.081 * S2
39013        E  =  3.990 + 2.014 * S
39014        ES =  1.720 + 0.986 * S
39015        S0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39016 C...X * C = X * CBAR :
39017        SF =  0.820
39018        AL =  0.929
39019        BE =  0.381
39020        AK =  1.228 - 0.231 * S
39021        BK =  3.806             - 0.337 * S2
39022        AG =  0.932 + 0.150 * S
39023        BG = -0.906
39024        C  =  1.133
39025        D  =   0.0  + 0.138 * S  - 0.028 * S2
39026        E  =  5.588 + 0.628 * S
39027        ES =  2.665 + 1.054 * S
39028        C0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39029 C...X * B = X * BBAR :
39030        SF =  1.297
39031        AL =  0.970
39032        BE =  0.207
39033        AK =  1.719 - 0.292 * S
39034        BK =  0.928 + 0.096 * S
39035        AG =  0.845 + 0.178 * S
39036        BG = -2.310
39037        C  =  1.558
39038        D  = -0.191 + 0.151 * S
39039        E  =  6.089 + 0.282 * S
39040        ES =  3.379 + 1.062 * S
39041        B0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39042
39043       END
39044
39045 *$ CREATE PHO_DORGF.FOR
39046 *COPY PHO_DORGF
39047 CDECK  ID>, PHO_DORGF
39048       DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39049      &                                   AG,BG,C,D,E,ES)
39050       IMPLICIT DOUBLE PRECISION (A - Z)
39051       SAVE
39052
39053        SX = SQRT (X)
39054        LX = LOG (1./X)
39055        PHO_DORGF  = (X**AK * (AG + BG * SX + C * X**BK)  +  S**AL
39056      1       * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39057
39058       END
39059
39060 *$ CREATE PHO_DORGFS.FOR
39061 *COPY PHO_DORGFS
39062 CDECK  ID>, PHO_DORGFS
39063       DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39064      &                                     C,D,E,ES)
39065       IMPLICIT DOUBLE PRECISION (A - Z)
39066       SAVE
39067
39068        IF (S .LE. SF) THEN
39069           PHO_DORGFS = 0.0
39070        ELSE
39071           SX = SQRT (X)
39072           LX = LOG (1./X)
39073           DS = S - SF
39074           PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39075      1         * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39076        END IF
39077
39078       END
39079
39080 *$ CREATE PHO_DORGLV.FOR
39081 *COPY PHO_DORGLV
39082 CDECK  ID>, PHO_DORGLV
39083 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39084 *                                                                 *
39085 *           G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS          *
39086 *                                                                 *
39087 *                 FOR A DETAILED EXPLANATION SEE                  *
39088 *                M. GLUECK, E.REYA, M. STRATMANN :                *
39089 *                    PHYS. REV. D51 (1995) 3220                   *
39090 *                                                                 *
39091 *   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
39092 *        Q**2 / GEV**2  BETWEEN   0.6   AND  5.E4                 *
39093 *                       AND (!)  Q**2 > 5 P**2                    *
39094 *        P**2 / GEV**2  BETWEEN   0.0   AND  10.                  *
39095 *                       P**2 = 0  <=> REAL PHOTON                 *
39096 *             X         BETWEEN  1.E-4  AND   1.                  *
39097 *                                                                 *
39098 *   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
39099 *                   M(C)  =  1.5,  M(B)  =  4.5                   *
39100 *   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
39101 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
39102 *             LAMBDA(5)  =  0.153,                                *
39103 *   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
39104 *   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
39105 *   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
39106 *                                                                 *
39107 *   PLEASE REPORT ANY STRANGE BEHAVIOUR TO :                      *
39108 *                  Marco.Stratmann@durham.ac.uk                   *
39109 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39110 *
39111 *...INPUT PARAMETERS :
39112 *
39113 *    X   = MOMENTUM FRACTION
39114 *    Q2  = SCALE Q**2 IN GEV**2
39115 *    P2  = VIRTUALITY OF THE PHOTON IN GEV**2
39116 *
39117 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39118 *
39119 ********************************************************
39120 *     subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39121       subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39122       implicit double precision (a-z)
39123       save
39124
39125 C  input/output channels
39126       INTEGER LI,LO
39127       COMMON /POINOU/ LI,LO
39128
39129       integer check
39130 c
39131 c     check limits :
39132 c
39133       check=0
39134       if(x.lt.0.0001d0) check=1
39135       if((q2.lt.0.6d0).or.(q2.gt.50000.d0))  check=1
39136       if(q2.lt.5.d0*p2) check=1
39137 c
39138 c     calculate distributions
39139 c
39140       if(check.eq.0) then
39141          call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39142       else
39143          WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39144          WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39145       endif
39146
39147       end
39148
39149 *$ CREATE PHO_grscalc.FOR
39150 *COPY PHO_grscalc
39151 CDECK  ID>, PHO_grscalc
39152       subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39153       implicit double precision (a-z)
39154       save
39155
39156       dimension u1(40),ds1(40),g1(40)
39157       dimension ud2(20),s2(20),g2(20)
39158       dimension up0(20),dsp0(20),gp0(20)
39159 CPH      save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
39160 c
39161       data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39162      &   0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39163      &   0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39164      &   0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39165      &   0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39166      &   -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39167      &   0.622d0,0.227d0,-0.184d0/
39168       data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39169      &   0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39170      &   0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39171      &   0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39172      &   0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39173      &   0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39174      &   0.245d0,-0.171d0/
39175       data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39176      &   -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39177      &   -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39178      &   0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39179      &   0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39180      &   0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39181       data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39182      &   0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39183      &   -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39184      &   -0.614d0,3.548d0/
39185       data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39186      &   -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39187      &   -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39188      &   -0.48d0,3.401d0/
39189       data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39190      &   -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39191      &   0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39192      &   -0.079d0/
39193       data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39194      &   0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39195      &   0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39196      &   2.294d0/
39197       data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39198      &   -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39199      &   0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39200      &   0.814d0,1.531d0,0.124d0/
39201       data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39202      &   -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39203      &   -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39204      &   2.264d0,0.2675d0/
39205 c
39206       mu2=0.25d0
39207       lam2=0.232d0*0.232d0
39208 c
39209       if(p2.le.0.25d0) then
39210          s=log(log(q2/lam2)/log(mu2/lam2))
39211          lp1=0.d0
39212          lp2=0.d0
39213       else
39214          s=log(log(q2/lam2)/log(p2/lam2))
39215          lp1=log(p2/mu2)*log(p2/mu2)
39216          lp2=log(p2/mu2+log(p2/mu2))
39217       endif
39218 c
39219       alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39220       bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39221       a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39222      &  (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39223       b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39224      &  (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39225      &  (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39226       gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39227      &  (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39228      &  (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39229       ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39230      &  (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39231       gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39232      &  (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39233       gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39234      &  (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39235       ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39236      &  (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39237       gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39238      &  (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39239       upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39240 c
39241       alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39242       bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39243       a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39244      &  (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39245       b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39246      &  (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39247      &  (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39248       gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39249      &  (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39250      &  (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39251       ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39252      &  (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39253       gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39254      &  (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39255       gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39256      &  (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39257       ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39258      &  (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39259       gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39260      &  (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39261       dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39262 c
39263       alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39264       bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39265       a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39266      &  (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39267       b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39268      &  (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39269       gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39270      &  (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39271       ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39272      &  (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39273      &  (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39274       gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39275      &  (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39276       gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39277      &  (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39278      &  (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39279       ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39280      &  (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39281       gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39282      &  (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39283       gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39284 c
39285       s=log(log(q2/lam2)/log(mu2/lam2))
39286       suppr=1.d0/(1.d0+p2/0.59d0)**2
39287 c
39288       alp=ud2(1)
39289       bet=ud2(2)
39290       a=ud2(3)+ud2(4)*s
39291       ga=ud2(5)+ud2(6)*s**0.5
39292       gc=ud2(7)+ud2(8)*s
39293       b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39294       gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39295       gd=ud2(15)+ud2(16)*s
39296       ge=ud2(17)+ud2(18)*s
39297       gep=ud2(19)+ud2(20)*s
39298       udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39299 c
39300       alp=s2(1)
39301       bet=s2(2)
39302       a=s2(3)+s2(4)*s
39303       ga=s2(5)+s2(6)*s**0.5
39304       gc=s2(7)+s2(8)*s
39305       b=s2(9)+s2(10)*s+s2(11)*s**2
39306       gb=s2(12)+s2(13)*s+s2(14)*s**2
39307       gd=s2(15)+s2(16)*s
39308       ge=s2(17)+s2(18)*s
39309       gep=s2(19)+s2(20)*s
39310       spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39311 c
39312       alp=g2(1)
39313       bet=g2(2)
39314       a=g2(3)+g2(4)*s**0.5
39315       b=g2(5)+g2(6)*s**2
39316       gb=g2(7)+g2(8)*s
39317       ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39318       gc=g2(12)+g2(13)*s**2
39319       gd=g2(14)+g2(15)*s+g2(16)*s**2
39320       ge=g2(17)+g2(18)*s
39321       gep=g2(19)+g2(20)*s
39322       gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39323 c
39324       ugam=upart1+udpart2
39325       dgam=dspart1+udpart2
39326       sgam=dspart1+spart2
39327       ggam=gpart1+gpart2
39328 c
39329       end
39330
39331 *$ CREATE PHO_grsf1.FOR
39332 *COPY PHO_grsf1
39333 CDECK  ID>, PHO_grsf1
39334       DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39335      &                                ge,gep)
39336       implicit double precision (a-z)
39337       save
39338
39339       PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39340      &      s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39341      &      (1.d0-x)**gd
39342
39343       end
39344
39345 *$ CREATE PHO_grsf2.FOR
39346 *COPY PHO_grsf2
39347 CDECK  ID>, PHO_grsf2
39348       DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39349      &                                ge,gep)
39350       implicit double precision (a-z)
39351       save
39352
39353       PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39354      &      s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39355      &      (1.d0-x)**gd
39356
39357       end
39358
39359 *$ CREATE PHO_CKMTPA.FOR
39360 *COPY PHO_CKMTPA
39361 CDECK  ID>, PHO_CKMTPA
39362       SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39363 C**********************************************************************
39364 C
39365 C     PDF based on Regge theory, evolved with .... by ....
39366 C
39367 C     input: IPAR     2212   proton (not installed)
39368 C                      990   Pomeron
39369 C
39370 C     output: parameters of parametrization
39371 C
39372 C**********************************************************************
39373       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39374       SAVE
39375
39376       CHARACTER*8 PDFNA
39377
39378 C  input/output channels
39379       INTEGER LI,LO
39380       COMMON /POINOU/ LI,LO
39381
39382       REAL PROP(40),POMP(40)
39383       DATA PROP /
39384      & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39385      & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39386      & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39387      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39388      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39389      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39390      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39391      & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39392       DATA POMP /
39393      & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39394      & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39395      & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
39396      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39397      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39398      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39399      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39400      & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39401
39402       IF(IPA.EQ.2212) THEN
39403         ALA  =PROP(1)
39404         Q2MI = PROP(39)
39405         Q2MA = PROP(40)
39406         PDFNA = 'CKMT-PRO'
39407       ELSE IF(IPA.EQ.990) THEN
39408         ALA  = POMP(1)
39409         Q2MI = POMP(39)
39410         Q2MA = POMP(40)
39411         PDFNA = 'CKMT-POM'
39412       ELSE
39413         WRITE(LO,'(1X,A,I7)')
39414      &    'PHO_CKMTPA:ERROR: invalid particle code',IPA
39415         STOP
39416       ENDIF
39417       XMI = 1.D-4
39418       XMA = 1.D0
39419       END
39420
39421 *$ CREATE PHO_CKMTPD.FOR
39422 *COPY PHO_CKMTPD
39423 CDECK  ID>, PHO_CKMTPD
39424       SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39425 C**********************************************************************
39426 C
39427 C     PDF based on Regge theory, evolved with .... by ....
39428 C
39429 C     input: IPAR     2212   proton (not installed)
39430 C                      990   Pomeron
39431 C
39432 C     output: PD(-6:6) x*f(x)  parton distribution functions
39433 C            (PDFLIB convention: d = PD(1), u = PD(2) )
39434 C
39435 C**********************************************************************
39436       SAVE
39437
39438 C  input/output channels
39439       INTEGER LI,LO
39440       COMMON /POINOU/ LI,LO
39441
39442       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP
39443       DIMENSION QQ(7)
39444
39445       Q2=SNGL(SCALE2)
39446       Q1S=Q2
39447       XX=SNGL(X)
39448 C  QCD lambda for evolution
39449       OWLAM = 0.23D0
39450       OWLAM2=OWLAM**2
39451 C  Q0**2 for evolution
39452       Q02 = 2.D0
39453 C
39454 C
39455 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39456 C                        q(6)=x*charm, q(7)=x*gluon
39457 C
39458       SB=0.
39459       IF(Q2-Q02) 1,1,2
39460     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39461     1 CONTINUE
39462       IF(IPAR.EQ.2212) THEN
39463 *       CALL PHO_CKMTPR(XX,SB,QQ
39464         WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39465         CALL PHO_ABORT
39466       ELSE
39467         CALL PHO_CKMTPO(XX,SB,QQ)
39468       ENDIF
39469 C
39470       PD(-6) = 0.D0
39471       PD(-5) = 0.D0
39472       PD(-4) = DBLE(QQ(6))
39473       PD(-3) = DBLE(QQ(3))
39474       PD(-2) = DBLE(QQ(4))
39475       PD(-1) = DBLE(QQ(5))
39476       PD(0)  = DBLE(QQ(7))
39477       PD(1)  = DBLE(QQ(2))
39478       PD(2)  = DBLE(QQ(1))
39479       PD(3)  = DBLE(QQ(3))
39480       PD(4)  = DBLE(QQ(6))
39481       PD(5)  = 0.D0
39482       PD(6)  = 0.D0
39483       IF(IPAR.EQ.990) THEN
39484         CDN = (PD(1)-PD(-1))/2.D0
39485         CUP = (PD(2)-PD(-2))/2.D0
39486         PD(-1) = PD(-1) + CDN
39487         PD(-2) = PD(-2) + CUP
39488         PD(1) = PD(-1)
39489         PD(2) = PD(-2)
39490       ENDIF
39491       END
39492
39493 *$ CREATE PHO_CKMTPO.FOR
39494 *COPY PHO_CKMTPO
39495 CDECK  ID>, PHO_CKMTPO
39496       SUBROUTINE PHO_CKMTPO(X,S,QQ)
39497 C**********************************************************************
39498 C
39499 C    calculation partons in Pomeron
39500 C
39501 C**********************************************************************
39502       SAVE
39503
39504       DIMENSION QQ(7)
39505
39506 C  input/output channels
39507       INTEGER LI,LO
39508       COMMON /POINOU/ LI,LO
39509
39510       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39511       EQUIVALENCE (GF(1,1,1),DL(1))
39512       DATA DELTA/.10/
39513
39514 C  RNG=  -.5
39515 C  DEU.NORM. QUARKS,GLUONS,NEW NORM   .6223E+00   .2754E+00   .1372E+01
39516 C  POM.NORM. QUARKS,GLUONS,ALL    .132E+00    .275E+00    .407E+00
39517       DATA (DL(K),K=    1,   85) /
39518      & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39519      & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39520      & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39521      & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39522      & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39523      & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39524      & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39525      & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39526      & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39527      & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39528      & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39529      & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39530      & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39531      & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39532      & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39533      & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39534      & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39535       DATA (DL(K),K=   86,  170) /
39536      & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39537      & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39538      & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39539      & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39540      & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39541      & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39542      & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39543      & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39544      & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39545      & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39546      & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39547      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39548      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39549      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39550      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39551      & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39552      & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39553       DATA (DL(K),K=  171,  255) /
39554      & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39555      & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39556      & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39557      & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39558      & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39559      & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39560      & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39561      & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39562      & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39563      & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39564      & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39565      & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39566      & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39567      & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39568      & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39569      & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39570      & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39571       DATA (DL(K),K=  256,  340) /
39572      & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39573      & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39574      & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39575      & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39576      & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
39577      & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
39578      & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
39579      & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
39580      & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39581      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39582      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39583      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39584      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39585      & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
39586      & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
39587      & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
39588      & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
39589       DATA (DL(K),K=  341,  425) /
39590      & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
39591      & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
39592      & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
39593      & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
39594      & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
39595      & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
39596      & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
39597      & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
39598      & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
39599      & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
39600      & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
39601      & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
39602      & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
39603      & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
39604      & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
39605      & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
39606      & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
39607       DATA (DL(K),K=  426,  510) /
39608      & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
39609      & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
39610      & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
39611      & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
39612      & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
39613      & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
39614      & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39615      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39616      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39617      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39618      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39619      & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
39620      & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
39621      & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
39622      & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
39623      & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
39624      & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
39625       DATA (DL(K),K=  511,  595) /
39626      & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
39627      & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
39628      & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
39629      & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
39630      & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
39631      & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
39632      & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
39633      & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
39634      & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
39635      & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
39636      & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
39637      & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
39638      & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
39639      & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
39640      & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
39641      & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
39642      & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
39643       DATA (DL(K),K=  596,  680) /
39644      & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
39645      & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
39646      & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
39647      & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
39648      & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39649      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39650      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39651      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39652      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39653      & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
39654      & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
39655      & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
39656      & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
39657      & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
39658      & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
39659      & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
39660      & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
39661       DATA (DL(K),K=  681,  765) /
39662      & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
39663      & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
39664      & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
39665      & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
39666      & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
39667      & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
39668      & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
39669      & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
39670      & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
39671      & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
39672      & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
39673      & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
39674      & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
39675      & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
39676      & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
39677      & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
39678      & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
39679       DATA (DL(K),K=  766,  850) /
39680      & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
39681      & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
39682      & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39683      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39684      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39685      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39686      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39687      & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
39688      & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
39689      & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
39690      & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
39691      & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
39692      & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
39693      & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
39694      & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
39695      & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
39696      & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
39697       DATA (DL(K),K=  851,  935) /
39698      & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
39699      & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
39700      & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
39701      & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
39702      & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
39703      & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
39704      & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
39705      & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
39706      & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
39707      & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
39708      & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
39709      & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
39710      & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
39711      & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
39712      & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
39713      & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
39714      & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
39715       DATA (DL(K),K=  936, 1020) /
39716      & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39717      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39718      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39719      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39720      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39721      & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
39722      & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
39723      & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
39724      & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
39725      & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
39726      & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
39727      & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
39728      & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
39729      & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
39730      & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
39731      & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
39732      & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
39733       DATA (DL(K),K= 1021, 1105) /
39734      & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
39735      & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
39736      & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
39737      & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
39738      & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
39739      & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
39740      & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
39741      & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
39742      & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
39743      & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
39744      & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
39745      & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
39746      & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
39747      & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
39748      & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
39749      & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39750      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39751       DATA (DL(K),K= 1106, 1190) /
39752      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39753      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39754      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39755      & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
39756      & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
39757      & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
39758      & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
39759      & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
39760      & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
39761      & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
39762      & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
39763      & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
39764      & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
39765      & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
39766      & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
39767      & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
39768      & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
39769       DATA (DL(K),K= 1191, 1275) /
39770      & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
39771      & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
39772      & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
39773      & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
39774      & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
39775      & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
39776      & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
39777      & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
39778      & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
39779      & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
39780      & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
39781      & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
39782      & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
39783      & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39784      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39785      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39786      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39787       DATA (DL(K),K= 1276, 1360) /
39788      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39789      & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
39790      & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
39791      & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
39792      & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
39793      & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
39794      & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
39795      & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
39796      & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
39797      & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
39798      & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
39799      & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
39800      & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
39801      & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
39802      & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
39803      & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
39804      & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
39805       DATA (DL(K),K= 1361, 1445) /
39806      & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
39807      & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
39808      & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
39809      & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
39810      & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
39811      & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
39812      & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
39813      & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
39814      & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
39815      & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
39816      & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
39817      & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39818      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39819      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39820      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39821      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39822      & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
39823       DATA (DL(K),K= 1446, 1530) /
39824      & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
39825      & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
39826      & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
39827      & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
39828      & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
39829      & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
39830      & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
39831      & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
39832      & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
39833      & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
39834      & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
39835      & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
39836      & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
39837      & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
39838      & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
39839      & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
39840      & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
39841       DATA (DL(K),K= 1531, 1615) /
39842      & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
39843      & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
39844      & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
39845      & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
39846      & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
39847      & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
39848      & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
39849      & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
39850      & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
39851      & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39852      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39853      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39854      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39855      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39856      & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
39857      & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
39858      & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
39859       DATA (DL(K),K= 1616, 1700) /
39860      & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
39861      & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
39862      & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
39863      & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
39864      & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
39865      & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
39866      & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
39867      & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
39868      & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
39869      & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
39870      & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
39871      & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
39872      & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
39873      & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
39874      & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
39875      & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
39876      & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
39877       DATA (DL(K),K= 1701, 1785) /
39878      & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
39879      & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
39880      & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
39881      & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
39882      & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
39883      & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
39884      & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
39885      & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39886      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39887      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39888      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39889      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39890      & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
39891      & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
39892      & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
39893      & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
39894      & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
39895       DATA (DL(K),K= 1786, 1870) /
39896      & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
39897      & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
39898      & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
39899      & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
39900      & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
39901      & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
39902      & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
39903      & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
39904      & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
39905      & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
39906      & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
39907      & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
39908      & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
39909      & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
39910      & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
39911      & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
39912      & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
39913       DATA (DL(K),K= 1871, 1955) /
39914      & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
39915      & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
39916      & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
39917      & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
39918      & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
39919      & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39920      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39921      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39922      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39923      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39924      & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
39925      & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
39926      & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
39927      & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
39928      & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
39929      & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
39930      & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
39931       DATA (DL(K),K= 1956, 2040) /
39932      & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
39933      & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
39934      & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
39935      & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
39936      & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
39937      & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
39938      & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
39939      & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
39940      & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
39941      & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
39942      & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
39943      & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
39944      & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
39945      & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
39946      & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
39947      & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
39948      & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
39949       DATA (DL(K),K= 2041, 2125) /
39950      & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
39951      & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
39952      & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
39953      & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39954      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39955      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39956      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39957      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39958      & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
39959      & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
39960      & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
39961      & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
39962      & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
39963      & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
39964      & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
39965      & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
39966      & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
39967       DATA (DL(K),K= 2126, 2210) /
39968      & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
39969      & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
39970      & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
39971      & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
39972      & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
39973      & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
39974      & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
39975      & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
39976      & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
39977      & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
39978      & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
39979      & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
39980      & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
39981      & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
39982      & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
39983      & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
39984      & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
39985       DATA (DL(K),K= 2211, 2295) /
39986      & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
39987      & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39988      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39989      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39990      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39991      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39992      & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
39993      & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
39994      & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
39995      & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
39996      & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
39997      & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
39998      & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
39999      & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
40000      & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
40001      & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
40002      & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
40003       DATA (DL(K),K= 2296, 2380) /
40004      & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
40005      & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
40006      & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
40007      & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
40008      & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
40009      & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
40010      & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
40011      & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
40012      & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
40013      & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
40014      & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
40015      & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
40016      & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
40017      & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
40018      & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
40019      & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
40020      & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40021       DATA (DL(K),K= 2381, 2465) /
40022      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40023      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40024      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40025      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40026      & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40027      & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40028      & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40029      & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40030      & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40031      & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40032      & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40033      & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40034      & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40035      & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40036      & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40037      & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40038      & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40039       DATA (DL(K),K= 2466, 2550) /
40040      & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40041      & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40042      & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40043      & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40044      & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40045      & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40046      & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40047      & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40048      & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40049      & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40050      & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40051      & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40052      & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40053      & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40054      & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40055      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40056      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40057       DATA (DL(K),K= 2551, 2635) /
40058      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40059      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40060      & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40061      & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40062      & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40063      & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40064      & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40065      & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40066      & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40067      & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40068      & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40069      & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40070      & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40071      & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40072      & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40073      & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40074      & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40075       DATA (DL(K),K= 2636, 2720) /
40076      & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40077      & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40078      & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40079      & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40080      & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40081      & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40082      & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40083      & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40084      & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40085      & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40086      & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40087      & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40088      & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40089      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40090      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40091      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40092      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40093       DATA (DL(K),K= 2721, 2805) /
40094      & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40095      & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40096      & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40097      & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40098      & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40099      & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40100      & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40101      & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40102      & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40103      & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40104      & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40105      & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40106      & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40107      & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40108      & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40109      & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40110      & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40111       DATA (DL(K),K= 2806, 2890) /
40112      & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40113      & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40114      & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40115      & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40116      & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40117      & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40118      & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40119      & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40120      & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40121      & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40122      & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40123      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40124      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40125      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40126      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40127      & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40128      & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40129       DATA (DL(K),K= 2891, 2975) /
40130      & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40131      & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40132      & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40133      & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40134      & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40135      & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40136      & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40137      & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40138      & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40139      & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40140      & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40141      & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40142      & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40143      & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40144      & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40145      & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40146      & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40147       DATA (DL(K),K= 2976, 3060) /
40148      & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40149      & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40150      & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40151      & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40152      & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40153      & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40154      & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40155      & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40156      & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40157      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40158      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40159      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40160      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40161      & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40162      & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40163      & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40164      & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40165       DATA (DL(K),K= 3061, 3145) /
40166      & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40167      & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40168      & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40169      & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40170      & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40171      & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40172      & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40173      & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40174      & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40175      & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40176      & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40177      & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40178      & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40179      & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40180      & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40181      & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40182      & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40183       DATA (DL(K),K= 3146, 3230) /
40184      & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40185      & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40186      & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40187      & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40188      & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40189      & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40190      & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40191      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40192      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40193      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40194      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40195      & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40196      & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40197      & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40198      & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40199      & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40200      & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40201       DATA (DL(K),K= 3231, 3315) /
40202      & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40203      & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40204      & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40205      & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40206      & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40207      & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40208      & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40209      & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40210      & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40211      & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40212      & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40213      & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40214      & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40215      & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40216      & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40217      & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40218      & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40219       DATA (DL(K),K= 3316, 3400) /
40220      & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40221      & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40222      & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40223      & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40224      & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40225      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40226      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40227      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40228      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40229      & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40230      & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40231      & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40232      & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40233      & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40234      & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40235      & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40236      & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40237       DATA (DL(K),K= 3401, 3485) /
40238      & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40239      & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40240      & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40241      & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40242      & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40243      & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40244      & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40245      & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40246      & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40247      & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40248      & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40249      & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40250      & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40251      & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40252      & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40253      & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40254      & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40255       DATA (DL(K),K= 3486, 3570) /
40256      & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40257      & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40258      & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40259      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40260      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40261      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40262      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40263      & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40264      & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40265      & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40266      & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40267      & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40268      & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40269      & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40270      & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40271      & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40272      & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40273       DATA (DL(K),K= 3571, 3655) /
40274      & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40275      & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40276      & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40277      & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40278      & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40279      & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40280      & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40281      & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40282      & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40283      & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40284      & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40285      & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40286      & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40287      & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40288      & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40289      & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40290      & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40291       DATA (DL(K),K= 3656, 3740) /
40292      & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40293      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40294      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40295      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40296      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40297      & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40298      & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40299      & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40300      & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40301      & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40302      & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40303      & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40304      & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40305      & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40306      & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40307      & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40308      & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40309       DATA (DL(K),K= 3741, 3825) /
40310      & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40311      & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40312      & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40313      & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40314      & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40315      & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40316      & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40317      & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40318      & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40319      & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40320      & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40321      & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40322      & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40323      & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40324      & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40325      & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40326      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40327       DATA (DL(K),K= 3826, 3910) /
40328      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40329      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40330      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40331      & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40332      & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40333      & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40334      & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40335      & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40336      & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40337      & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40338      & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40339      & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40340      & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40341      & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40342      & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40343      & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40344      & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40345       DATA (DL(K),K= 3911, 3995) /
40346      & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40347      & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40348      & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40349      & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40350      & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40351      & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40352      & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40353      & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40354      & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40355      & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40356      & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40357      & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40358      & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40359      & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40360      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40361      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40362      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40363       DATA (DL(K),K= 3996, 4000) /
40364      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40365
40366       DO 10 I=1,7
40367         QQ(I) = 0.
40368  10   CONTINUE
40369       IF(X.GT.0.9985) RETURN
40370
40371       IS = S/DELTA+1
40372       IS = MIN(IS,19)
40373       IS1 = IS+1
40374       DO 20 I=1,7
40375         IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40376         IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40377         DO 30 L=1,25
40378           F1(L)=GF(I,IS,L)
40379           F2(L)=GF(I,IS1,L)
40380  30     CONTINUE
40381         S1=(IS-1)*DELTA
40382         S2=S1+DELTA
40383         A1 = PHO_CKMTFV(X,F1)
40384         A2 = PHO_CKMTFV(X,F2)
40385         QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40386  19     CONTINUE
40387  20   CONTINUE
40388
40389       END
40390
40391 *$ CREATE PHO_CKMTFV.FOR
40392 *COPY PHO_CKMTFV
40393 CDECK  ID>, PHO_CKMTFV
40394       REAL FUNCTION PHO_CKMTFV(X,FVL)
40395 C**********************************************************************
40396 C
40397 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40398 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40399 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40400 C     IN MAIN ROUTINE.
40401 C
40402 C**********************************************************************
40403       SAVE
40404
40405       DIMENSION FVL(25),XGRID(25)
40406
40407 C  input/output channels
40408       INTEGER LI,LO
40409       COMMON /POINOU/ LI,LO
40410
40411       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40412      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40413
40414       PHO_CKMTFV=0.
40415       DO 1 I=1,NX
40416       IF(X.LT.XGRID(I)) GO TO 2
40417     1 CONTINUE
40418     2 I=I-1
40419       IF(I.EQ.0) THEN
40420          I=I+1
40421       ELSE IF(I.GT.23) THEN
40422          I=23
40423       ENDIF
40424       J=I+1
40425       K=J+1
40426       AXI=LOG(XGRID(I))
40427       BXI=LOG(1.-XGRID(I))
40428       AXJ=LOG(XGRID(J))
40429       BXJ=LOG(1.-XGRID(J))
40430       AXK=LOG(XGRID(K))
40431       BXK=LOG(1.-XGRID(K))
40432       FI=LOG(ABS(FVL(I)) +1.E-15)
40433       FJ=LOG(ABS(FVL(J)) +1.E-16)
40434       FK=LOG(ABS(FVL(K)) +1.E-17)
40435       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40436       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40437      $ BXI))/DET
40438       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40439       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40440       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40441      1RETURN
40442 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40443 C         WRITE(LO,2001) X,FVL
40444 C 2001    FORMAT(8E12.4)
40445 C         WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40446 C      ENDIF
40447       PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40448
40449       END
40450
40451 *$ CREATE PHO_SASGAM.FOR
40452 *COPY PHO_SASGAM
40453 CDECK  ID>, PHO_SASGAM
40454 C***********************************************************************
40455 C...SaSgam version 2 - parton distributions of the photon
40456 C...by Gerhard A. Schuler and Torbjorn Sjostrand
40457 C...For further information see Z. Phys. C68 (1995) 607
40458 C...and Phys. Lett. B376 (1996) 193.
40459
40460 C...18 January 1996: original code.
40461 C...22 July 1996: calculation of BETA moved in SASBEH.
40462
40463 C!!!Note that one further call parameter - IP2 - has been added
40464 C!!!to the SASGAM argument list compared with version 1.
40465
40466 C...The user should only need to call the SASGAM routine,
40467 C...which in turn calls the auxiliary routines SASVMD, SASANO,
40468 C...SASBEH and SASDIR. The package is self-contained.
40469
40470 C...One particular aspect of these parametrizations is that F2 for
40471 C...the photon is not obtained just as the charge-squared-weighted
40472 C...sum of quark distributions, but differ in the treatment of
40473 C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40474 C...the kinematics range of heavy-flavour production, but the same
40475 C...kinematics is not relevant e.g. for jet production) and, for the
40476 C...'MSbar' fits, in the addition of a Cgamma term related to the
40477 C...separation of direct processes. Schematically:
40478 C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40479 C...F2  = VMD (rho, omega, phi) + anomalous (d, u, s) +
40480 C...      Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40481 C...The J/psi and Upsilon states have not been included in the VMD sum,
40482 C...but low c and b masses in the other components should compensate
40483 C...for this in a duality sense.
40484
40485 C...The calling sequence is the following:
40486 C     CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40487 C...with the following declaration statement:
40488 C     DIMENSION XPDFGM(-6:6)
40489 C...and, optionally, further information in:
40490 C     COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40491 C    &XPDIR(-6:6)
40492 C     COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40493 C...Input:  ISET = 1 : SaS set 1D ('DIS',   Q0 = 0.6 GeV)
40494 C                = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40495 C                = 3 : SaS set 2D ('DIS',   Q0 =  2  GeV)
40496 C                = 4 : SaS set 2M ('MSbar', Q0 =  2  GeV)
40497 C           X : x value.
40498 C           Q2 : Q2 value.
40499 C           P2 : P2 value; should be = 0. for an on-shell photon.
40500 C           IP2 : scheme used to evaluate off-shell anomalous component.
40501 C               = 0 : recommended default, see = 7.
40502 C               = 1 : dipole dampening by integration; very time-consuming.
40503 C               = 2 : P_0^2 = max( Q_0^2, P^2 )
40504 C               = 3 : P_0^2 = Q_0^2 + P^2.
40505 C               = 4 : P_{eff} that preserves momentum sum.
40506 C               = 5 : P_{int} that preserves momentum and average
40507 C                     evolution range.
40508 C               = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40509 C               = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40510 C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40511 C           XPFDGM :  x times parton distribution functions of the photon,
40512 C               with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40513 C               6 = t (always empty!), - for antiquarks (result is same).
40514 C...The breakdown by component is stored in the commonblock SASCOM,
40515 C               with elements as above.
40516 C           XPVMD : rho, omega, phi VMD part only of output.
40517 C           XPANL : d, u, s anomalous part only of output.
40518 C           XPANH : c, b anomalous part only of output.
40519 C           XPBEH : c, b Bethe-Heitler part only of output.
40520 C           XPDIR : Cgamma (direct contribution) part only of output.
40521 C...The above arrays do not distinguish valence and sea contributions,
40522 C...although this information is available internally. The additional
40523 C...commonblock SASVAL provides the valence part only of the above
40524 C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40525 C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40526 C...and therefore not given doubly. VXPDGM gives the sum of valence
40527 C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40528 C...and so on, gives the sea part only.
40529 C***********************************************************************
40530
40531       SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40532 C...Purpose: to construct the F2 and parton distributions of the photon
40533 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40534 C...For F2, c and b are included by the Bethe-Heitler formula;
40535 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40536       SAVE
40537       DIMENSION XPDFGM(-6:6)
40538
40539 C  input/output channels
40540       INTEGER LI,LO
40541       COMMON /POINOU/ LI,LO
40542
40543       COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40544      &XPDIR(-6:6)
40545       COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40546 CPH      SAVE /SASCOM/,/SASVAL/
40547
40548 C...Temporary array.
40549       DIMENSION XPGA(-6:6), VXPGA(-6:6)
40550 C...Charm and bottom masses (low to compensate for J/psi etc.).
40551       DATA PMC/1.3/, PMB/4.6/
40552 C...alpha_em and alpha_em/(2*pi).
40553       DATA AEM/0.007297/, AEM2PI/0.0011614/
40554 C...Lambda value for 4 flavours.
40555       DATA ALAM/0.20/
40556 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40557       DATA FRACU/0.8/
40558 C...VMD couplings f_V**2/(4*pi).
40559       DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40560 C...Masses for rho (=omega) and phi.
40561       DATA PMRHO/0.770/, PMPHI/1.020/
40562 C...Number of points in integration for IP2=1.
40563       DATA NSTEP/100/
40564
40565 C...Reset output.
40566       F2GM=0.
40567       DO 100 KFL=-6,6
40568       XPDFGM(KFL)=0.
40569       XPVMD(KFL)=0.
40570       XPANL(KFL)=0.
40571       XPANH(KFL)=0.
40572       XPBEH(KFL)=0.
40573       XPDIR(KFL)=0.
40574       VXPVMD(KFL)=0.
40575       VXPANL(KFL)=0.
40576       VXPANH(KFL)=0.
40577       VXPDGM(KFL)=0.
40578   100 CONTINUE
40579
40580 C...Check that input sensible.
40581       IF(ISET.LE.0.OR.ISET.GE.5) THEN
40582         WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
40583         WRITE(LO,*) ' ISET = ',ISET
40584         STOP
40585       ENDIF
40586       IF(X.LE.0..OR.X.GT.1.) THEN
40587         WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
40588         WRITE(LO,*) ' X = ',X
40589         STOP
40590       ENDIF
40591
40592 C...Set Q0 cut-off parameter as function of set used.
40593       IF(ISET.LE.2) THEN
40594         Q0=0.6
40595       ELSE
40596         Q0=2.
40597       ENDIF
40598       Q02=Q0**2
40599
40600 C...Scale choice for off-shell photon; common factors.
40601       Q2A=Q2
40602       FACNOR=1.
40603       IF(IP2.EQ.1) THEN
40604         P2MX=P2+Q02
40605         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40606         FACNOR=LOG(Q2/Q02)/NSTEP
40607       ELSEIF(IP2.EQ.2) THEN
40608         P2MX=MAX(P2,Q02)
40609       ELSEIF(IP2.EQ.3) THEN
40610         P2MX=P2+Q02
40611         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40612       ELSEIF(IP2.EQ.4) THEN
40613         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40614      &  ((Q2+P2)*(Q02+P2)))
40615       ELSEIF(IP2.EQ.5) THEN
40616         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40617      &  ((Q2+P2)*(Q02+P2)))
40618         P2MX=Q0*SQRT(P2MXA)
40619         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40620       ELSEIF(IP2.EQ.6) THEN
40621         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40622      &  ((Q2+P2)*(Q02+P2)))
40623         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40624       ELSE
40625         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40626      &  ((Q2+P2)*(Q02+P2)))
40627         P2MX=Q0*SQRT(P2MXA)
40628         P2MXB=P2MX
40629         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40630         P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
40631         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40632       ENDIF
40633
40634 C...Call VMD parametrization for d quark and use to give rho, omega,
40635 C...phi. Note dipole dampening for off-shell photon.
40636       CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40637       XFVAL=VXPGA(1)
40638       XPGA(1)=XPGA(2)
40639       XPGA(-1)=XPGA(-2)
40640       FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40641       FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40642       DO 110 KFL=-5,5
40643       XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40644   110 CONTINUE
40645       XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
40646       XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40647       XPVMD(3)=XPVMD(3)+FACS*XFVAL
40648       XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
40649       XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40650       XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40651       VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
40652       VXPVMD(2)=FRACU*FACUD*XFVAL
40653       VXPVMD(3)=FACS*XFVAL
40654       VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
40655       VXPVMD(-2)=FRACU*FACUD*XFVAL
40656       VXPVMD(-3)=FACS*XFVAL
40657
40658       IF(IP2.NE.1) THEN
40659 C...Anomalous parametrizations for different strategies
40660 C...for off-shell photons; except full integration.
40661
40662 C...Call anomalous parametrization for d + u + s.
40663         CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40664         DO 120 KFL=-5,5
40665         XPANL(KFL)=FACNOR*XPGA(KFL)
40666         VXPANL(KFL)=FACNOR*VXPGA(KFL)
40667   120   CONTINUE
40668
40669 C...Call anomalous parametrization for c and b.
40670         CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40671         DO 130 KFL=-5,5
40672         XPANH(KFL)=FACNOR*XPGA(KFL)
40673         VXPANH(KFL)=FACNOR*VXPGA(KFL)
40674   130   CONTINUE
40675         CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40676         DO 140 KFL=-5,5
40677         XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40678         VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40679   140   CONTINUE
40680
40681       ELSE
40682 C...Special option: loop over flavours and integrate over k2.
40683         DO 170 KF=1,5
40684         DO 160 ISTEP=1,NSTEP
40685         Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
40686         IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40687      &  (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40688         CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40689         FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40690         IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
40691         IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
40692         DO 150 KFL=-5,5
40693         IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40694         IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40695         IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40696         IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40697   150   CONTINUE
40698   160   CONTINUE
40699   170   CONTINUE
40700       ENDIF
40701
40702 C...Call Bethe-Heitler term expression for charm and bottom.
40703       CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
40704       XPBEH(4)=XPBH
40705       XPBEH(-4)=XPBH
40706       CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
40707       XPBEH(5)=XPBH
40708       XPBEH(-5)=XPBH
40709
40710 C...For MSbar subtraction call C^gamma term expression for d, u, s.
40711       IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40712         CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
40713         DO 180 KFL=-5,5
40714         XPDIR(KFL)=XPGA(KFL)
40715   180   CONTINUE
40716       ENDIF
40717
40718 C...Store result in output array.
40719       DO 190 KFL=-5,5
40720       CHSQ=1./9.
40721       IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
40722       XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40723       IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40724       XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40725       VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40726   190 CONTINUE
40727
40728       RETURN
40729       END
40730
40731 C*********************************************************************
40732
40733 *$ CREATE PHO_SASVMD.FOR
40734 *COPY PHO_SASVMD
40735 CDECK  ID>, PHO_SASVMD
40736       SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40737 C...Purpose: to evaluate the VMD parton distributions of a photon,
40738 C...evolved homogeneously from an initial scale P2 to Q2.
40739 C...Does not include dipole suppression factor.
40740 C...ISET is parton distribution set, see above;
40741 C...additionally ISET=0 is used for the evolution of an anomalous photon
40742 C...which branched at a scale P2 and then evolved homogeneously to Q2.
40743 C...ALAM is the 4-flavour Lambda, which is automatically converted
40744 C...to 3- and 5-flavour equivalents as needed.
40745       SAVE
40746       DIMENSION XPGA(-6:6), VXPGA(-6:6)
40747
40748 C  input/output channels
40749       INTEGER LI,LO
40750       COMMON /POINOU/ LI,LO
40751
40752       DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40753
40754 C...Reset output.
40755       DO 100 KFL=-6,6
40756       XPGA(KFL)=0.
40757       VXPGA(KFL)=0.
40758   100 CONTINUE
40759       KFA=IABS(KF)
40760
40761 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40762       ALAM3=ALAM*(PMC/ALAM)**(2./27.)
40763       ALAM5=ALAM*(ALAM/PMB)**(2./23.)
40764       P2EFF=MAX(P2,1.2*ALAM3**2)
40765       IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40766       IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40767       Q2EFF=MAX(Q2,P2EFF)
40768
40769 C...Find number of flavours at lower and upper scale.
40770       NFP=4
40771       IF(P2EFF.LT.PMC**2) NFP=3
40772       IF(P2EFF.GT.PMB**2) NFP=5
40773       NFQ=4
40774       IF(Q2EFF.LT.PMC**2) NFQ=3
40775       IF(Q2EFF.GT.PMB**2) NFQ=5
40776
40777 C...Find s as sum of 3-, 4- and 5-flavour parts.
40778       S=0.
40779       IF(NFP.EQ.3) THEN
40780         Q2DIV=PMC**2
40781         IF(NFQ.EQ.3) Q2DIV=Q2EFF
40782         S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40783       ENDIF
40784       IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40785         P2DIV=P2EFF
40786         IF(NFP.EQ.3) P2DIV=PMC**2
40787         Q2DIV=Q2EFF
40788         IF(NFQ.EQ.5) Q2DIV=PMB**2
40789         S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40790       ENDIF
40791       IF(NFQ.EQ.5) THEN
40792         P2DIV=PMB**2
40793         IF(NFP.EQ.5) P2DIV=P2EFF
40794         S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40795       ENDIF
40796
40797 C...Calculate frequent combinations of x and s.
40798       X1=1.-X
40799       XL=-LOG(X)
40800       S2=S**2
40801       S3=S**3
40802       S4=S**4
40803
40804 C...Evaluate homogeneous anomalous parton distributions below or
40805 C...above threshold.
40806       IF(ISET.EQ.0) THEN
40807       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40808      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40809         XVAL = X * 1.5 * (X**2+X1**2)
40810         XGLU = 0.
40811         XSEA = 0.
40812       ELSE
40813         XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
40814      &  (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
40815      &  X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
40816         XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
40817      &  X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
40818      &  ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
40819         XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
40820      &  X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
40821      &  ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
40822      &  (2.*X-1.)*X*XL**2)
40823       ENDIF
40824
40825 C...Evaluate set 1D parton distributions below or above threshold.
40826       ELSEIF(ISET.EQ.1) THEN
40827       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40828      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40829         XVAL = 1.294 * X**0.80 * X1**0.76
40830         XGLU = 1.273 * X**0.40 * X1**1.76
40831         XSEA = 0.100 * X1**3.76
40832       ELSE
40833         XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
40834      &  X1**(0.76+0.667*S) * XL**(2.*S)
40835         XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
40836      &  X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
40837      &  1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
40838         XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
40839      &  X**(-7.32*S2/(1.+10.3*S2)) *
40840      &  X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
40841         XSEA0 = 0.100 * X1**3.76
40842       ENDIF
40843
40844 C...Evaluate set 1M parton distributions below or above threshold.
40845       ELSEIF(ISET.EQ.2) THEN
40846       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40847      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40848         XVAL = 0.8477 * X**0.51 * X1**1.37
40849         XGLU = 3.42 * X**0.255 * X1**2.37
40850         XSEA = 0.
40851       ELSE
40852         XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
40853      &  * X1**1.37 * XL**(2.667*S)
40854         XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
40855      &  X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
40856      &  XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
40857      &  X1**(2.37+3.*S)
40858         XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
40859      &  X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
40860      &  XL**(2.8*S)
40861         XSEA0 = 0.
40862       ENDIF
40863
40864 C...Evaluate set 2D parton distributions below or above threshold.
40865       ELSEIF(ISET.EQ.3) THEN
40866       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40867      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40868         XVAL = X**0.46 * X1**0.64 + 0.76 * X
40869         XGLU = 1.925 * X1**2
40870         XSEA = 0.242 * X1**4
40871       ELSE
40872         XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
40873      &  * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
40874      &  (0.76+0.4*S) * X * X1**(2.667*S)
40875         XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
40876      &  EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
40877      &  * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
40878         XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
40879      &  X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
40880         XSEA0 = 0.242 * X1**4
40881       ENDIF
40882
40883 C...Evaluate set 2M parton distributions below or above threshold.
40884       ELSEIF(ISET.EQ.4) THEN
40885       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40886      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40887         XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
40888         XGLU = 1.808 * X1**2
40889         XSEA = 0.209 * X1**4
40890       ELSE
40891         XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
40892      &  X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
40893      &  X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
40894      &  (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
40895         XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
40896      &  X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
40897      &  X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
40898      &  XL**(10.9*S/(1.+2.5*S))
40899         XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
40900      &  X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
40901      &  X1**(4.+S) * XL**(0.45*S)
40902         XSEA0 = 0.209 * X1**4
40903       ENDIF
40904       ENDIF
40905
40906 C...Threshold factors for c and b sea.
40907       SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40908       XCHM=0.
40909       IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
40910         SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40911         IF(ISET.EQ.0) THEN
40912           XCHM=XSEA*(1.-(SCH/SLL)**2)
40913         ELSE
40914           XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
40915         ENDIF
40916       ENDIF
40917       XBOT=0.
40918       IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
40919         SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40920         IF(ISET.EQ.0) THEN
40921           XBOT=XSEA*(1.-(SBT/SLL)**2)
40922         ELSE
40923           XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
40924         ENDIF
40925       ENDIF
40926
40927 C...Fill parton distributions.
40928       XPGA(0)=XGLU
40929       XPGA(1)=XSEA
40930       XPGA(2)=XSEA
40931       XPGA(3)=XSEA
40932       XPGA(4)=XCHM
40933       XPGA(5)=XBOT
40934       XPGA(KFA)=XPGA(KFA)+XVAL
40935       DO 110 KFL=1,5
40936       XPGA(-KFL)=XPGA(KFL)
40937   110 CONTINUE
40938       VXPGA(KFA)=XVAL
40939       VXPGA(-KFA)=XVAL
40940
40941       RETURN
40942       END
40943
40944 C*********************************************************************
40945
40946 *$ CREATE PHO_SASANO.FOR
40947 *COPY PHO_SASANO
40948 CDECK  ID>, PHO_SASANO
40949       SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40950 C...Purpose: to evaluate the parton distributions of the anomalous
40951 C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
40952 C...to Q2.
40953 C...KF=0 gives the sum over (up to) 5 flavours,
40954 C...KF<0 limits to flavours up to abs(KF),
40955 C...KF>0 is for flavour KF only.
40956 C...ALAM is the 4-flavour Lambda, which is automatically converted
40957 C...to 3- and 5-flavour equivalents as needed.
40958       SAVE
40959
40960 C  input/output channels
40961       INTEGER LI,LO
40962       COMMON /POINOU/ LI,LO
40963
40964       DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40965       DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40966
40967 C...Reset output.
40968       DO 100 KFL=-6,6
40969       XPGA(KFL)=0.
40970       VXPGA(KFL)=0.
40971   100 CONTINUE
40972       IF(Q2.LE.P2) RETURN
40973       KFA=IABS(KF)
40974
40975 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40976       ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
40977       ALAMSQ(4)=ALAM**2
40978       ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
40979       P2EFF=MAX(P2,1.2*ALAMSQ(3))
40980       IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40981       IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40982       Q2EFF=MAX(Q2,P2EFF)
40983       XL=-LOG(X)
40984
40985 C...Find number of flavours at lower and upper scale.
40986       NFP=4
40987       IF(P2EFF.LT.PMC**2) NFP=3
40988       IF(P2EFF.GT.PMB**2) NFP=5
40989       NFQ=4
40990       IF(Q2EFF.LT.PMC**2) NFQ=3
40991       IF(Q2EFF.GT.PMB**2) NFQ=5
40992
40993 C...Define range of flavour loop.
40994       IF(KF.EQ.0) THEN
40995         KFLMN=1
40996         KFLMX=5
40997       ELSEIF(KF.LT.0) THEN
40998         KFLMN=1
40999         KFLMX=KFA
41000       ELSE
41001         KFLMN=KFA
41002         KFLMX=KFA
41003       ENDIF
41004
41005 C...Loop over flavours the photon can branch into.
41006       DO 110 KFL=KFLMN,KFLMX
41007
41008 C...Light flavours: calculate t range and (approximate) s range.
41009       IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
41010         TDIFF=LOG(Q2EFF/P2EFF)
41011         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41012      &  LOG(P2EFF/ALAMSQ(NFQ)))
41013         IF(NFQ.GT.NFP) THEN
41014           Q2DIV=PMB**2
41015           IF(NFQ.EQ.4) Q2DIV=PMC**2
41016           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41017      &    LOG(P2EFF/ALAMSQ(NFQ)))
41018           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41019      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
41020           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41021         ENDIF
41022         IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41023           Q2DIV=PMC**2
41024           SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41025      &    LOG(P2EFF/ALAMSQ(4)))
41026           SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41027      &    LOG(P2EFF/ALAMSQ(3)))
41028           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41029         ENDIF
41030
41031 C...u and s quark do not need a separate treatment when d has been done.
41032       ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41033
41034 C...Charm: as above, but only include range above c threshold.
41035       ELSEIF(KFL.EQ.4) THEN
41036         IF(Q2.LE.PMC**2) GOTO 110
41037         P2EFF=MAX(P2EFF,PMC**2)
41038         Q2EFF=MAX(Q2EFF,P2EFF)
41039         TDIFF=LOG(Q2EFF/P2EFF)
41040         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41041      &  LOG(P2EFF/ALAMSQ(NFQ)))
41042         IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41043           Q2DIV=PMB**2
41044           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41045      &    LOG(P2EFF/ALAMSQ(NFQ)))
41046           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41047      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
41048           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41049         ENDIF
41050
41051 C...Bottom: as above, but only include range above b threshold.
41052       ELSEIF(KFL.EQ.5) THEN
41053         IF(Q2.LE.PMB**2) GOTO 110
41054         P2EFF=MAX(P2EFF,PMB**2)
41055         Q2EFF=MAX(Q2,P2EFF)
41056         TDIFF=LOG(Q2EFF/P2EFF)
41057         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41058      &  LOG(P2EFF/ALAMSQ(NFQ)))
41059       ENDIF
41060
41061 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41062       CHSQ=1./9.
41063       IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41064       FAC=AEM2PI*2.*CHSQ*TDIFF
41065
41066 C...Evaluate parton distributions (normalized to unit momentum sum).
41067       IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41068         XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41069      &  (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41070      &  1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41071      &  X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41072         XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41073      &  X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41074      &  ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41075         XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41076      &  X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41077      &  ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41078      &  (2.*X-1.)*X*XL**2)
41079
41080 C...Threshold factors for c and b sea.
41081         SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41082         XCHM=0.
41083         IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41084           SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41085           XCHM=XSEA*(1.-(SCH/SLL)**3)
41086         ENDIF
41087         XBOT=0.
41088         IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41089           SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41090           XBOT=XSEA*(1.-(SBT/SLL)**3)
41091         ENDIF
41092       ENDIF
41093
41094 C...Add contribution of each valence flavour.
41095       XPGA(0)=XPGA(0)+FAC*XGLU
41096       XPGA(1)=XPGA(1)+FAC*XSEA
41097       XPGA(2)=XPGA(2)+FAC*XSEA
41098       XPGA(3)=XPGA(3)+FAC*XSEA
41099       XPGA(4)=XPGA(4)+FAC*XCHM
41100       XPGA(5)=XPGA(5)+FAC*XBOT
41101       XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41102       VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41103   110 CONTINUE
41104       DO 120 KFL=1,5
41105       XPGA(-KFL)=XPGA(KFL)
41106       VXPGA(-KFL)=VXPGA(KFL)
41107   120 CONTINUE
41108
41109       END
41110
41111 C*********************************************************************
41112
41113 *$ CREATE PHO_SASBEH.FOR
41114 *COPY PHO_SASBEH
41115 CDECK  ID>, PHO_SASBEH
41116       SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41117 C...Purpose: to evaluate the Bethe-Heitler cross section for
41118 C...heavy flavour production.
41119       SAVE
41120       DATA AEM2PI/0.0011614/
41121
41122 C...Reset output.
41123       XPBH=0.
41124       SIGBH=0.
41125
41126 C...Check kinematics limits.
41127       IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41128       W2=Q2*(1.-X)/X-P2
41129       BETA2=1.-4.*PM2/W2
41130       IF(BETA2.LT.1E-10) RETURN
41131       BETA=SQRT(BETA2)
41132       RMQ=4.*PM2/Q2
41133
41134 C...Simple case: P2 = 0.
41135       IF(P2.LT.1E-4) THEN
41136         IF(BETA.LT.0.99) THEN
41137           XBL=LOG((1.+BETA)/(1.-BETA))
41138         ELSE
41139           XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41140         ENDIF
41141         SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41142      &  XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41143
41144 C...Complicated case: P2 > 0, based on approximation of
41145 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41146       ELSE
41147         RPQ=1.-4.*X**2*P2/Q2
41148         IF(RPQ.GT.1E-10) THEN
41149           RPBE=SQRT(RPQ*BETA2)
41150           IF(RPBE.LT.0.99) THEN
41151             XBL=LOG((1.+RPBE)/(1.-RPBE))
41152             XBI=2.*RPBE/(1.-RPBE**2)
41153           ELSE
41154             RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41155             XBL=LOG((1.+RPBE)**2/RPBESN)
41156             XBI=2.*RPBE/RPBESN
41157           ENDIF
41158           SIGBH=BETA*(6.*X*(1.-X)-1.)+
41159      &    XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41160      &    XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41161         ENDIF
41162       ENDIF
41163
41164 C...Multiply by charge-squared etc. to get parton distribution.
41165       CHSQ=1./9.
41166       IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41167       XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41168
41169       END
41170
41171 C*********************************************************************
41172
41173 *$ CREATE PHO_SASDIR.FOR
41174 *COPY PHO_SASDIR
41175 CDECK  ID>, PHO_SASDIR
41176       SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41177 C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41178 C...as needed in MSbar parametrizations.
41179       SAVE
41180       DIMENSION XPGA(-6:6)
41181       DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41182
41183 C...Reset output.
41184       DO 100 KFL=-6,6
41185       XPGA(KFL)=0.
41186   100 CONTINUE
41187
41188 C...Evaluate common x-dependent expression.
41189       XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41190       CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41191
41192 C...d, u, s part by simple charge factor.
41193       XPGA(1)=(1./9.)*CGAM
41194       XPGA(2)=(4./9.)*CGAM
41195       XPGA(3)=(1./9.)*CGAM
41196
41197 C...Also fill for antiquarks.
41198       DO 110 KF=1,5
41199       XPGA(-KF)=XPGA(KF)
41200   110 CONTINUE
41201
41202       END
41203
41204 *$ CREATE PHO_PHGAL.FOR
41205 *COPY PHO_PHGAL
41206 CDECK  ID>, PHO_PHGAL
41207       SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41208 C***********************************************************************
41209 C
41210 C     photon parton densities with built-in momentum sum rule and
41211 C     Regge-based low-x behaviour
41212 C
41213 C     H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41214 C     e-Print Archive: hep-ph/9711355
41215 C
41216 C     code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41217 C
41218 C***********************************************************************
41219       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41220       SAVE
41221
41222       PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41223       DOUBLE PRECISION
41224      &       XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41225      &       XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41226
41227       DIMENSION NA(NARG)
41228
41229       DATA ZEROD/0.D0/
41230
41231 C...100 x values; in (D-4,.77) log spaced (78 points)
41232 C...              in (.78,.995) lineary spaced (22 points)
41233       DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41234       DATA XT/
41235      &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41236      &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41237      &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41238      &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41239      &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41240      &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41241      &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41242      &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41243      &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41244      &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41245      &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41246      &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41247      &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41248      &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41249      &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41250      &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41251      &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41252
41253 C...place for DATA blocks
41254       DATA (XPV(I,1,0),I=1,100)/
41255      &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41256      &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41257      &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41258      &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41259      &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41260      &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41261      &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41262      &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41263      &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41264      &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41265      &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41266      &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41267      &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41268      &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41269      &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41270      &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41271      &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41272       DATA (XPV(I,1,1),I=1,100)/
41273      &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41274      &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41275      &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41276      &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41277      &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41278      &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41279      &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41280      &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41281      &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41282      &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41283      &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41284      &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41285      &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41286      &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41287      &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41288      &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41289      &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41290       DATA (XPV(I,1,2),I=1,100)/
41291      &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41292      &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41293      &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41294      &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41295      &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41296      &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41297      &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41298      &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41299      &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41300      &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41301      &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41302      &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41303      &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41304      &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41305      &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41306      &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41307      &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41308       DATA (XPV(I,1,3),I=1,100)/
41309      &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41310      &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41311      &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41312      &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41313      &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41314      &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41315      &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41316      &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41317      &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41318      &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41319      &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41320      &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41321      &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41322      &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41323      &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41324      &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41325      &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41326       DATA (XPV(I,1,4),I=1,100)/
41327      &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41328      &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41329      &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41330      &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41331      &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41332      &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41333      &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41334      &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41335      &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41336      &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41337      &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41338      &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41339      &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41340      &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41341      &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41342      &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41343      &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41344       DATA (XPV(I,2,0),I=1,100)/
41345      &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41346      &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41347      &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41348      &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41349      &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41350      &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41351      &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41352      &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41353      &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41354      &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41355      &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41356      &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41357      &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41358      &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41359      &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41360      &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41361      &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41362       DATA (XPV(I,2,1),I=1,100)/
41363      &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41364      &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41365      &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41366      &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41367      &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41368      &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41369      &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41370      &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41371      &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41372      &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41373      &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41374      &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41375      &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41376      &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41377      &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41378      &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41379      &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41380       DATA (XPV(I,2,2),I=1,100)/
41381      &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41382      &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41383      &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41384      &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41385      &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41386      &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41387      &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41388      &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41389      &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41390      &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41391      &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41392      &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41393      &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41394      &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41395      &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41396      &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41397      &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41398       DATA (XPV(I,2,3),I=1,100)/
41399      &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41400      &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41401      &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41402      &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41403      &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41404      &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41405      &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41406      &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41407      &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41408      &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41409      &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41410      &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41411      &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41412      &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41413      &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41414      &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41415      &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41416       DATA (XPV(I,2,4),I=1,100)/
41417      &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41418      &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41419      &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41420      &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41421      &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41422      &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41423      &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41424      &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41425      &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41426      &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41427      &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41428      &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41429      &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41430      &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41431      &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41432      &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41433      &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41434       DATA (XPV(I,3,0),I=1,100)/
41435      &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41436      &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41437      &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41438      &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41439      &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41440      &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41441      &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41442      &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41443      &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41444      &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41445      &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41446      &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41447      &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41448      &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41449      &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41450      &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41451      &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41452       DATA (XPV(I,3,1),I=1,100)/
41453      &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41454      &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41455      &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41456      &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41457      &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41458      &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41459      &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41460      &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41461      &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41462      &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41463      &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41464      &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41465      &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41466      &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41467      &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41468      &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41469      &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41470       DATA (XPV(I,3,2),I=1,100)/
41471      &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41472      &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41473      &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41474      &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41475      &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41476      &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41477      &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41478      &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41479      &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41480      &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41481      &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41482      &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41483      &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41484      &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41485      &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41486      &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41487      &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41488       DATA (XPV(I,3,3),I=1,100)/
41489      &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41490      &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41491      &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41492      &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41493      &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41494      &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41495      &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41496      &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41497      &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41498      &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41499      &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41500      &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41501      &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41502      &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41503      &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41504      &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41505      &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41506       DATA (XPV(I,3,4),I=1,100)/
41507      &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41508      &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41509      &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41510      &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41511      &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41512      &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41513      &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41514      &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41515      &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41516      &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41517      &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41518      &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41519      &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41520      &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41521      &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41522      &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41523      &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41524       DATA (XPV(I,4,0),I=1,100)/
41525      &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41526      &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41527      &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41528      &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41529      &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41530      &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41531      &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41532      &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41533      &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41534      &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41535      &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41536      &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41537      &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41538      &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41539      &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41540      &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41541      &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41542       DATA (XPV(I,4,1),I=1,100)/
41543      &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41544      &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41545      &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41546      &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41547      &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41548      &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41549      &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41550      &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41551      &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41552      &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41553      &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41554      &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41555      &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41556      &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41557      &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41558      &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41559      &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41560       DATA (XPV(I,4,2),I=1,100)/
41561      &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41562      &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41563      &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41564      &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41565      &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41566      &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41567      &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41568      &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41569      &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41570      &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41571      &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41572      &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41573      &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41574      &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
41575      &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
41576      &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
41577      &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
41578       DATA (XPV(I,4,3),I=1,100)/
41579      &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
41580      &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
41581      &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
41582      &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
41583      &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
41584      &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
41585      &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
41586      &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
41587      &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
41588      &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
41589      &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
41590      &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
41591      &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
41592      &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
41593      &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
41594      &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
41595      &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
41596       DATA (XPV(I,4,4),I=1,100)/
41597      &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
41598      &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
41599      &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
41600      &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
41601      &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
41602      &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
41603      &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
41604      &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
41605      &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
41606      &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
41607      &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
41608      &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
41609      &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
41610      &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
41611      &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
41612      &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
41613      &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
41614       DATA (XPV(I,5,0),I=1,100)/
41615      &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
41616      &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
41617      &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
41618      &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
41619      &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
41620      &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
41621      &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
41622      &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
41623      &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
41624      &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
41625      &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
41626      &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
41627      &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
41628      &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
41629      &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
41630      &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
41631      &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
41632       DATA (XPV(I,5,1),I=1,100)/
41633      &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
41634      &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
41635      &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
41636      &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
41637      &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
41638      &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
41639      &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
41640      &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
41641      &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
41642      &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
41643      &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
41644      &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
41645      &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
41646      &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
41647      &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
41648      &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
41649      &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
41650       DATA (XPV(I,5,2),I=1,100)/
41651      &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
41652      &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
41653      &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
41654      &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
41655      &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
41656      &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
41657      &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
41658      &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
41659      &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
41660      &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
41661      &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
41662      &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
41663      &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
41664      &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
41665      &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
41666      &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
41667      &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
41668       DATA (XPV(I,5,3),I=1,100)/
41669      &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
41670      &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
41671      &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
41672      &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
41673      &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
41674      &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
41675      &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
41676      &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
41677      &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
41678      &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
41679      &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
41680      &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
41681      &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
41682      &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
41683      &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
41684      &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
41685      &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
41686       DATA (XPV(I,5,4),I=1,100)/
41687      &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
41688      &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
41689      &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
41690      &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
41691      &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
41692      &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
41693      &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
41694      &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
41695      &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
41696      &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
41697      &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
41698      &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
41699      &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
41700      &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
41701      &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
41702      &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
41703      &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
41704       DATA (XPV(I,6,0),I=1,100)/
41705      &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
41706      &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
41707      &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
41708      &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
41709      &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
41710      &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
41711      &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
41712      &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
41713      &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
41714      &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
41715      &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
41716      &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
41717      &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
41718      &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
41719      &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
41720      &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
41721      &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
41722       DATA (XPV(I,6,1),I=1,100)/
41723      &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
41724      &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
41725      &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
41726      &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
41727      &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
41728      &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
41729      &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
41730      &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
41731      &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
41732      &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
41733      &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
41734      &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
41735      &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
41736      &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
41737      &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
41738      &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
41739      &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
41740       DATA (XPV(I,6,2),I=1,100)/
41741      &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
41742      &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
41743      &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
41744      &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
41745      &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
41746      &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
41747      &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
41748      &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
41749      &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
41750      &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
41751      &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
41752      &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
41753      &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
41754      &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
41755      &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
41756      &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
41757      &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
41758       DATA (XPV(I,6,3),I=1,100)/
41759      &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
41760      &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
41761      &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
41762      &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
41763      &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
41764      &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
41765      &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
41766      &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
41767      &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
41768      &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
41769      &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
41770      &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
41771      &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
41772      &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
41773      &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
41774      &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
41775      &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
41776       DATA (XPV(I,6,4),I=1,100)/
41777      &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
41778      &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
41779      &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
41780      &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
41781      &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
41782      &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
41783      &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
41784      &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
41785      &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
41786      &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
41787      &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
41788      &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
41789      &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
41790      &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
41791      &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
41792      &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
41793      &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
41794       DATA (XPV(I,7,0),I=1,100)/
41795      &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
41796      &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
41797      &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
41798      &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
41799      &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
41800      &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
41801      &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
41802      &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
41803      &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
41804      &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
41805      &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
41806      &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
41807      &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
41808      &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
41809      &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
41810      &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
41811      &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
41812       DATA (XPV(I,7,1),I=1,100)/
41813      &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
41814      &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
41815      &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
41816      &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
41817      &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
41818      &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
41819      &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
41820      &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
41821      &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
41822      &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
41823      &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
41824      &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
41825      &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
41826      &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
41827      &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
41828      &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
41829      &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
41830       DATA (XPV(I,7,2),I=1,100)/
41831      &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
41832      &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
41833      &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
41834      &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
41835      &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
41836      &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
41837      &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
41838      &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
41839      &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
41840      &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
41841      &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
41842      &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
41843      &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
41844      &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
41845      &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
41846      &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
41847      &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
41848       DATA (XPV(I,7,3),I=1,100)/
41849      &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
41850      &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
41851      &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
41852      &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
41853      &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
41854      &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
41855      &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
41856      &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
41857      &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
41858      &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
41859      &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
41860      &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
41861      &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
41862      &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
41863      &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
41864      &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
41865      &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
41866       DATA (XPV(I,7,4),I=1,100)/
41867      &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
41868      &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
41869      &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
41870      &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
41871      &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
41872      &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
41873      &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
41874      &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
41875      &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
41876      &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
41877      &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
41878      &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
41879      &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
41880      &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
41881      &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
41882      &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
41883      &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
41884
41885 C..fetching pdfs
41886       DO  5 IP=-6,6
41887         XPDF(IP)=ZEROD
41888  5    CONTINUE
41889       DO 2 I=1,IX
41890         ENT(I)=LOG10(XT(I))
41891   2   CONTINUE
41892       NA(1)=IX
41893       NA(2)=IQ
41894       DO 3 I=1,IQ
41895         ENT(IX+I)=LOG10(Q2T(I))
41896    3  CONTINUE
41897       ARG(1)=LOG10(X)
41898       ARG(2)=LOG10(Q2)
41899 C..various flavours (u-->2,d-->1)
41900       XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
41901       XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
41902       XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
41903       XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
41904       XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
41905       DO 21 JF=1,4
41906         XPDF(-JF)=XPDF(JF)
41907  21   CONTINUE
41908
41909       END
41910
41911 *$ CREATE PHO_DBFINT.FOR
41912 *COPY PHO_DBFINT
41913 CDECK  ID>, PHO_DBFINT
41914       DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
41915 C***********************************************************************
41916 C
41917 C     routine based on CERN library E104
41918 C
41919 C     multi-dimensional interpolation routine, needed for PHOJET
41920 C     internal cross section tables and several PDF sets (GRV98 and AGL)
41921 C
41922 C     changed to avoid recursive function calls (R.Engel, 09/98)
41923 C
41924 C***********************************************************************
41925       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41926       SAVE
41927
41928       INTEGER NA(NARG), INDEX(32)
41929       DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
41930
41931       DATA ZEROD/0.D0/
41932       DATA ONED/1.D0/
41933
41934       DBFINT    =  ZEROD
41935       PHO_DBFINT =  ZEROD
41936       IF(NARG .LT. 1  .OR.  NARG .GT. 5)  RETURN
41937
41938            LMAX      =  0
41939            ISTEP     =  1
41940            KNOTS     =  1
41941            INDEX(1)  =  1
41942            WEIGHT(1) =  ONED
41943            DO 100    N  =  1, NARG
41944               X     =  ARG(N)
41945               NDIM  =  NA(N)
41946               LOCA  =  LMAX
41947               LMIN  =  LMAX + 1
41948               LMAX  =  LMAX + NDIM
41949               IF(NDIM .GT. 2)  GOTO 10
41950               IF(NDIM .EQ. 1)  GOTO 100
41951               H  =  X - ENT(LMIN)
41952               IF(H .EQ. ZEROD)  GOTO 90
41953               ISHIFT  =  ISTEP
41954               IF(X-ENT(LMIN+1) .EQ. ZEROD)  GOTO 21
41955               ISHIFT  =  0
41956               ETA     =  H / (ENT(LMIN+1) - ENT(LMIN))
41957               GOTO 30
41958    10         LOCB  =  LMAX + 1
41959    11         LOCC  =  (LOCA+LOCB) / 2
41960               IF(X-ENT(LOCC))  12, 20, 13
41961    12         LOCB  =  LOCC
41962               GOTO 14
41963    13         LOCA  =  LOCC
41964    14         IF(LOCB-LOCA .GT. 1)  GOTO 11
41965               LOCA    =  MIN ( MAX (LOCA,LMIN), LMAX-1 )
41966               ISHIFT  =  (LOCA - LMIN) * ISTEP
41967               ETA     =  (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
41968               GOTO 30
41969    20         ISHIFT  =  (LOCC - LMIN) * ISTEP
41970    21         DO 22  K  =  1, KNOTS
41971                  INDEX(K)  =  INDEX(K) + ISHIFT
41972    22         CONTINUE
41973               GOTO 90
41974    30         DO 31  K  =  1, KNOTS
41975                  INDEX(K)         =  INDEX(K) + ISHIFT
41976                  INDEX(K+KNOTS)   =  INDEX(K) + ISTEP
41977                  WEIGHT(K+KNOTS)  =  WEIGHT(K) * ETA
41978                  WEIGHT(K)        =  WEIGHT(K) - WEIGHT(K+KNOTS)
41979    31         CONTINUE
41980               KNOTS  =  2*KNOTS
41981    90         ISTEP  =  ISTEP * NDIM
41982   100      CONTINUE
41983            DO 200    K  =  1, KNOTS
41984               I  =  INDEX(K)
41985               DBFINT =  DBFINT + WEIGHT(K) * TABLE(I)
41986   200      CONTINUE
41987
41988       PHO_DBFINT = DBFINT
41989
41990       END
41991
41992 *$ CREATE PHVAL.FOR
41993 *COPY PHVAL
41994 CDECK  ID>, PHVAL
41995       SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
41996 C**********************************************************************
41997 C
41998 C   dummy subroutine, remove to link PHOLIB
41999 C
42000 C**********************************************************************
42001       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42002       DIMENSION PD(-6:6)
42003       END