DPMJET/phojet1.12-35c4.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
  35 C                interface to PYTHIA 6.1 (or higher)
  36
  37 C     for usage in DPMJET 3.x (Lund common block dimensions increased)
  38
  39 C
  40 C***********************************************************************
  41 C
  42 C
  43 C             List of subroutines and functions
  44 C             ---------------------------------
  45 C
  46 C
  47 C  main event simulation routines
  48 C
  49 C      PHO_EVENT
  50 C      PHO_PARTON
  51 C      PHO_POSPOM
  52 C
  53 C      PHO_STDPAR
  54 C      PHO_POMSCA
  55 C
  56 C
  57 C  user steering interface
  58 C
  59 C      PHO_SETMDL
  60 C      PHO_PRESEL
  61 C
  62 C
  63 C  experimental setup / photon flux calculation
  64 C
  65 C      PHO_FIXLAB
  66 C      PHO_FIXCOL
  67 C      PHO_GPHERA
  68 C      PHO_GGEPEM
  69 C      PHO_WGEPEM
  70 C      PHO_GGBLSR
  71 C      PHO_GGBEAM
  72 C      PHO_GGHIOF
  73 C      PHO_GGHIOG
  74 C      PHO_GGFLCL
  75 C      PHO_GGFLCR
  76 C      PHO_GGFAUX
  77 C      PHO_GGFNUC
  78 C      PHO_GHHIOF
  79 C      PHO_GHHIAS
  80 C
  81 C
  82 C  initialization
  83 C
  84 C      PHO_INIT
  85 C      PHO_DATINI
  86 C      PHO_PARDAT
  87 C      PHO_MCINI
  88 C
  89 C      PHO_EVEINI
  90 C
  91 C      PHO_HARINI
  92 C      PHO_FRAINI
  93 C
  94 C      PHO_FITPAR
  95 C
  96 C
  97 C  cross section calculation
  98 C
  99 C      PHO_CSINT
 100 C
 101 C      PHO_XSECT
 102 C      PHO_BORNCS
 103 C      PHO_HARXTO
 104 C
 105 C      PHO_DSIGDT
 106 C
 107 C      PHO_TRIREG
 108 C      PHO_LOOREG
 109 C      PHO_TRXPOM
 110 C
 111 C      PHO_EIKON
 112 C      PHO_CHAN2A
 113 C
 114 C      PHO_SCALES
 115 C
 116 C
 117 C  multiple interaction structure
 118 C
 119 C      PHO_IMPAMP
 120 C      PHO_PRBDIS
 121 C      PHO_SAMPRO
 122 C      PHO_SAMPRB
 123 C
 124 C
 125 C  hadron / photon remnant treatment, soft x selection
 126 C
 127 C      PHO_HARREM
 128 C      PHO_PARREM
 129 C
 130 C      PHO_HADSP2
 131 C      PHO_HADSP3
 132 C      PHO_SOFTXX
 133 C      PHO_SELSXR
 134 C      PHO_SELSX2
 135 C      PHO_SELSXS
 136 C      PHO_SELSXI
 137 C
 138 C      PHO_VALFLA
 139 C      PHO_REGFLA
 140 C      PHO_SEAFLA
 141 C      PHO_FLAUX
 142 C      PHO_BETAF
 143 C      IPHO_DIQU
 144 C
 145 C
 146 C  primordial kt and soft parton pt
 147 C
 148 C      PHO_PRIMKT
 149 C      PHO_PARTPT
 150 C      PHO_SOFTPT
 151 C      PHO_SELPT
 152 C
 153 C      PHO_CONN0
 154 C      PHO_CONN1
 155 C
 156 C
 157 C  simulation of hard scattering, initial state radiation
 158 C
 159 C      PHO_HARCOL
 160 C      PHO_SELCOL
 161 C      PHO_HARCOR
 162 C
 163 C      PHO_HARDIR
 164 C      PHO_HARX12
 165 C      PHO_HARDX1
 166 C      PHO_HARKIN
 167 C      PHO_HARWGH
 168 C      PHO_HARSCA
 169 C      PHO_HARFAC
 170 C      PHO_HARWGX
 171 C      PHO_HARWGI
 172 C      PHO_HARINT
 173 C      PHO_HARMCI
 174 C
 175 C      PHO_HARXR3
 176 C      PHO_HARXR2
 177 C      PHO_HARXD2
 178 C      PHO_HARXPT
 179 C      PHO_HARISR
 180 C      PHO_HARZSP
 181 C
 182 C      PHO_PTCUT
 183 C      PHO_ALPHAE
 184 C      PHO_ALPHAS
 185 C
 186 C
 187 C  diffraction dissociation
 188 C
 189 C      PHO_DIFDIS
 190 C      PHO_DIFPRO
 191 C      PHO_DIFPAR
 192 C      PHO_QELAST
 193 C      PHO_CDIFF
 194 C      PHO_DFWRAP
 195 C
 196 C      PHO_SAMASS
 197 C      PHO_DSIGDM
 198 C      PHO_DFMASS
 199 C
 200 C      PHO_SDECAY
 201 C      PHO_SDECY2
 202 C      PHO_SDECY3
 203 C
 204 C      PHO_DIFSLP
 205 C      PHO_DIFKIN
 206 C      PHO_VECRES
 207 C      PHO_DIFRES
 208 C
 209 C      PHO_REGPAR
 210 C
 211 C      PHO_PECMS
 212 C      PHO_SETPAR
 213 C
 214 C
 215 C  fragmentation, treatment of low-mass strings
 216 C
 217 C      PHO_STRING
 218 C      PHO_STRFRA
 219 C
 220 C      PHO_ID2STR
 221 C      PHO_MCHECK
 222 C      PHO_POMCOR
 223 C      PHO_MASCOR
 224 C      PHO_PARCOR
 225 C
 226 C      PHO_GLU2QU
 227 C      PHO_GLUSPL
 228 C
 229 C      PHO_DQMASS
 230 C      PHO_BAMASS
 231 C      PHO_MEMASS
 232 C
 233 C
 234 C  particle code tables, particle numbering conversion
 235 C
 236 C      PHO_PNAME
 237 C      PHO_PMASS
 238 C      IPHO_CHR3
 239 C      IPHO_BAR3
 240 C
 241 C      IPHO_ANTI
 242 C
 243 C      IPHO_PDG2ID
 244 C      IPHO_ID2PDG
 245 C      IPHO_LU2PDG
 246 C      IPHO_PDG2LU
 247 C
 248 C      IPHO_CNV1
 249 C      PHO_HACODE
 250 C
 251 C
 252 C
 253 C  Lorentz transformations, rotations and mass adjustment
 254 C
 255 C      PHO_ALTRA
 256 C      PHO_LTRANS
 257 C      PHO_TRANS
 258 C      PHO_TRANI
 259 C
 260 C      PHO_MKSLTR
 261 C      PHO_GETLTR
 262 C
 263 C      PHO_LTRHEP
 264 C
 265 C      PHO_MSHELL
 266 C      PHO_MASSAD
 267 C
 268 C
 269 C  program debugging and internal cross-checks
 270 C
 271 C      PHO_PREVNT
 272 C      PHO_PRSTRG
 273 C      PHO_CHECK
 274 C
 275 C      PHO_TRACE
 276 C
 277 C      PHO_REJSTA
 278 C
 279 C      PHO_ABORT
 280 C
 281 C
 282 C  cross section fitting
 283 C
 284 C      PHO_FITMAI
 285 C      PHO_FITINP
 286 C      PHO_FITDAT
 287 C      PHO_FITOUT
 288 C      PHO_FITAMP
 289 C      PHO_FITTST
 290 C      PHO_FITMSQ
 291 C      PHO_FITVD1
 292 C      PHO_FITCN1
 293 C      PHO_FITINI
 294 C
 295 C
 296 C  cross section parametrizations
 297 C
 298 C      PHO_HADCSL
 299 C      PHO_ALLM97
 300 C      PHO_CSDIFF
 301 C
 302
 303 C
 304 C  random numbers
 305 C
 306
 307 C      DPMJET random number generator DT_RNDM used
 308
 309 C
 310 C      PHO_SFECFE
 311 C      PHO_RNDBET
 312 C      PHO_RNDGAM
 313 C
 314 C
 315 C  auxiliary routines / numerical methods
 316 C
 317 C      PHO_GAUSET
 318 C      PHO_GAUDAT
 319 C
 320 C      pho_samp1d
 321 C
 322 C      PHO_DZEROX
 323 C      PHO_EXPINT
 324 C      PHO_BESSJ0
 325 C      PHO_BESSI0
 326 C      pho_ExpBessI0
 327 C      PHO_BESSI1
 328 C      PHO_BESSK0
 329 C      PHO_BESSK1
 330 C
 331 C      PHO_XLAM
 332 C
 333 C      PHO_SWAPD
 334 C      PHO_SWAPI
 335 C
 336 C
 337 C  parton density parametrization management / interface
 338 C
 339 C      PHO_PDF
 340 C
 341 C      PHO_SETPDF
 342 C      PHO_GETPDF
 343 C      PHO_ACTPDF
 344 C
 345 C      PHO_QPMPDF
 346 C
 347 C      PHO_PDFTST
 348 C
 349 C
 350 C  parton density parametrizations from other authors
 351 C
 352 C      PHO_DOR98LO
 353 C      PHO_DOR98SC
 354 C      PHO_DOR94LO
 355 C      PHO_DOR94HO
 356 C      PHO_DOR94DI
 357 C      PHO_DOR92LO
 358 C      PHO_DOR92HO
 359 C      PHO_DORPLO
 360 C      PHO_DORPHO
 361 C      PHO_DORGLO
 362 C      PHO_DORGHO
 363 C      PHO_DORGH0
 364 C      PHO_DOR94FV
 365 C      PHO_DOR94FW
 366 C      PHO_DOR94FS
 367 C      PHO_DOR92FV
 368 C      PHO_DOR92FW
 369 C      PHO_DOR92FS
 370 C      PHO_DORFVP
 371 C      PHO_DORFGP
 372 C      PHO_DORFQP
 373 C      PHO_DORGF
 374 C      PHO_DORGFS
 375 C      PHO_grsf1
 376 C      PHO_grsf2
 377 C
 378 C      PHO_CKMTPA
 379 C      PHO_CKMTPD
 380 C      PHO_CKMTPO
 381 C      PHO_CKMTFV
 382 C
 383 C      PHO_DBFINT
 384 C
 385 C      PHO_SASGAM
 386 C      PHO_SASVMD
 387 C      PHO_SASANO
 388 C      PHO_SASBEH
 389 C      PHO_SASDIR
 390 C
 391 C      PHO_PHGAL
 392 C      PHVAL
 393 C
 394 C
 395 C***********************************************************************
 396
 397 *$ CREATE PHO_INIT.FOR
 398 *COPY PHO_INIT
 399 CDECK  ID>, PHO_INIT
 400       SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
 401 C***********************************************************************
 402 C
 403 C     main subroutine to configure and manage PHOJET calculations
 404 C
 405 C     input:  LINP       input unit to read from
 406 C                        -1 to skip reading of input file
 407 C             LOUT       output unit to write to
 408 C
 409 C     output: IREJ       0  success
 410 C                        1  failure
 411 C
 412 C***********************************************************************
 413       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
 414       SAVE
 415
 416 C  input/output channels
 417       INTEGER LI,LO
 418       COMMON /POINOU/ LI,LO
 419 C  event debugging information
 420       INTEGER NMAXD
 421       PARAMETER (NMAXD=100)
 422       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
 423      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 424       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
 425      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 426 C  model switches and parameters
 427       CHARACTER*8 MDLNA
 428       INTEGER ISWMDL,IPAMDL
 429       DOUBLE PRECISION PARMDL
 430       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
 431 C  general process information
 432       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
 433       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
 434
 435 C  global event kinematics and particle IDs
 436       INTEGER IFPAP,IFPAB
 437       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
 438       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
 439 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
 440       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
 441       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
 442       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
 443      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
 444 C  integration precision for hard cross sections (obsolete)
 445       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 446       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 447 C  some hadron information, will be deleted in future versions
 448       INTEGER NFS
 449       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
 450       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
 451 C  obsolete cut-off information
 452       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
 453       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
 454 C  photon flux kinematics and cuts
 455       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
 456      &                 YMIN1,YMAX1,YMIN2,YMAX2,
 457      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 458      &                 THMIN1,THMAX1,THMIN2,THMAX2
 459       INTEGER          ITAG1,ITAG2
 460       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
 461      &                YMIN1,YMAX1,YMIN2,YMAX2,
 462      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 463      &                THMIN1,THMAX1,THMIN2,THMAX2,
 464      &                ITAG1,ITAG2
 465 C  cut probability distribution
 466       INTEGER IEETA1,IIMAX,KKMAX
 467       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
 468       INTEGER IEEMAX,IMAX,KMAX
 469       REAL PROB
 470       DOUBLE PRECISION EPTAB
 471       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
 472      &                IEEMAX,IMAX,KMAX
 473 C  event weights and generated cross section
 474       INTEGER IPOWGC,ISWCUT,IVWGHT
 475       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
 476       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
 477      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
 478 C  names of hard scattering processes
 479       INTEGER Max_pro_1
 480       PARAMETER ( Max_pro_1 = 16 )
 481       CHARACTER*18 PROC
 482       COMMON /POHPRO/ PROC(0:Max_pro_1)
 483 C  hard cross sections and MC selection weights
 484       INTEGER Max_pro_2
 485       PARAMETER ( Max_pro_2 = 16 )
 486       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
 487      &  MH_acc_1,MH_acc_2
 488       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
 489       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
 490      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
 491      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
 492      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
 493      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
 494
 495       INTEGER MSTU,MSTJ
 496       DOUBLE PRECISION PARU,PARJ
 497       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 498
 499       INTEGER KCHG
 500       DOUBLE PRECISION  PMAS,PARF,VCKM
 501       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
 502
 503       INTEGER MDCY,MDME,KFDP
 504       DOUBLE PRECISION  BRAT
 505       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
 506
 507       INTEGER PYCOMP
 508
 509       DIMENSION ITMP(0:11)
 510       CHARACTER*10 CNAME
 511       CHARACTER*70 NUMBER,FILENA
 512
 513  14   FORMAT(A10,A69)
 514  15   FORMAT(A12)
 515
 516 C  define input/output units
 517       IF(LINP.GE.0) THEN
 518         LI = LINP
 519       ELSE
 520         LI = 5
 521       ENDIF
 522       LO = LOUT
 523
 524       IREJ = 0
 525
 526       WRITE(LO,*)
 527       WRITE(LO,*) ' ==================================================='
 528       WRITE(LO,*) '                                                    '
 529       WRITE(LO,*) '      ----      PHOJET version 1.12      ----      '
 530       WRITE(LO,*) '                                                    '
 531       WRITE(LO,*) ' ==================================================='
 532       WRITE(LO,*) '     Authors: Ralph Engel      (FZ Karlsruhe)'
 533       WRITE(LO,*) '              Johannes Ranft   (Siegen Univ.)'
 534       WRITE(LO,*) '              Stefan Roesler   (CERN)'
 535       WRITE(LO,*) ' ---------------------------------------------------'
 536       WRITE(LO,*) '   Manual, updates, and further information:'
 537       WRITE(LO,*) '    http://www-ik.fzk.de/~engel/phojet.html'
 538       WRITE(LO,*) ' ---------------------------------------------------'
 539       WRITE(LO,*) '    please send suggestions / bug reports etc. to:'
 540       WRITE(LO,*) '             ralph.engel@fzk.de'
 541       WRITE(LO,*) ' ==================================================='
 542       WRITE(LO,*) '   $Date: 2000/06/25 21:59:19 $'
 543       WRITE(LO,*) '   $Revision: 1.12.1.35 $'
 544
 545       WRITE(LO,*) '   (code version with interface to PYTHIA 6.x)'
 546
 547       WRITE(LO,*) '   (code version for usage in DPMJET 3.x)'
 548
 549       WRITE(LO,*) ' ==================================================='
 550       WRITE(LO,*)
 551
 552 C  standard initializations
 553       CALL PHO_DATINI
 554       CALL PHO_PARDAT
 555       DUM = PHO_PMASS(0,-1)
 556
 557 C  initialize standard PDFs
 558 C  proton
 559       CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
 560       CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
 561 C  neutron
 562       CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
 563       CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
 564 C  photon
 565       CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
 566 C  pomeron
 567       CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
 568 C  pions
 569       CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
 570       CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
 571       CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
 572 C  kaons
 573       CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
 574       CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
 575       CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
 576       CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
 577
 578 C  nothing to be done
 579       IF(LINP.LT.0) RETURN
 580
 581 C  main loop to read input cards
 582  1200 CONTINUE
 583         READ(LINP,14,END=1300) CNAME,NUMBER
 584         IF(CNAME.EQ.'ENDINPUT  ') THEN
 585           GOTO 1300
 586         ELSE IF(CNAME.EQ.'STOP      ') THEN
 587           WRITE(LO,*) 'STOP'
 588           STOP
 589         ELSE IF(CNAME.EQ.'COMMENT   ') THEN
 590           WRITE(LO,'(1X,A10,A69)') 'COMMENT   ',NUMBER
 591         ELSE IF(CNAME(1:1).EQ.'*') THEN
 592           WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
 593         ELSE IF(CNAME.EQ.'PTCUT     ') THEN
 594           READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
 595           WRITE(LO,*) 'PTCUT     ',PARMDL(36),PARMDL(37),
 596      &      PARMDL(38),PARMDL(39)
 597         ELSE IF(CNAME.EQ.'PROCESS   ') THEN
 598           READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
 599           WRITE(LO,*) 'PROCESS   ',(IPRON(KK,1),KK=1,8)
 600         ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
 601           READ(NUMBER,*) (ITMP(KK),KK=0,11)
 602           WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
 603           DO 112 KK=1,8
 604             IPRON(KK,ITMP(0)) = ITMP(KK)
 605  112      CONTINUE
 606         ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
 607           READ(NUMBER,*) IMPRO,IP,ION
 608           WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
 609           MH_pro_on(IMPRO,IP) = ION
 610         ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
 611           READ(NUMBER,*) IDPDG,PVIR
 612           IHFLS(1) = 1
 613           XPSUB = 1.D0
 614           CALL PHO_SETPAR(1,IDPDG,0,PVIR)
 615           WRITE(LO,*) 'PARTICLE1  ',IDPDG,PVIR
 616         ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
 617           READ(NUMBER,*) IDPDG,PVIR
 618           IHFLS(2) = 1
 619           XTSUB = 1.D0
 620           CALL PHO_SETPAR(2,IDPDG,0,PVIR)
 621           WRITE(LO,*) 'PARTICLE2  ',IDPDG,PVIR
 622         ELSE IF(CNAME.EQ.'REMNANT1  ') THEN
 623           READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
 624           IHFLS(1) = IVAL
 625           IHFLD(1,1) = IFL1
 626           IHFLD(1,2) = IFL2
 627           XPSUB = XSUB
 628           PVIR = 0.D0
 629           CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
 630           WRITE(LO,*) 'REMNANT1   ',IDPDG,IFL1,IFL2,IVAL,XSUB
 631         ELSE IF(CNAME.EQ.'REMNANT2  ') THEN
 632           READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
 633           IHFLS(2) = IVAL
 634           IHFLD(2,1) = IFL1
 635           IHFLD(2,2) = IFL2
 636           XTSUB = XSUB
 637           PVIR = 0.D0
 638           CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
 639           WRITE(LO,*) 'REMNANT2   ',IDPDG,IFL1,IFL2,IVAL,XSUB
 640         ELSE IF(CNAME.EQ.'PDF       ') THEN
 641           READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
 642           WRITE(LO,*) 'PDF        ',IDPDG,IPAR,ISET,IEXT
 643           CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
 644         ELSE IF(CNAME.EQ.'SETMODEL  ') THEN
 645           READ(NUMBER,*) I,IVAL
 646           WRITE(LO,*) 'SETMODEL   ',I,IVAL
 647           CALL PHO_SETMDL(I,IVAL,1)
 648         ELSE IF(CNAME.EQ.'SETPARAM  ') THEN
 649           READ(NUMBER,*) I,PARNEW
 650           WRITE(LO,*) 'SETPARAM   ',I,PARNEW
 651           PARMDL(I) = PARNEW
 652         ELSE IF(CNAME.EQ.'DEBUG     ') THEN
 653           READ(NUMBER,*) IDEBF,IDEBN,IDLEV
 654           WRITE(LO,*) 'DEBUG      ',IDEBF,IDEBN,IDLEV
 655           CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
 656         ELSE IF(CNAME.EQ.'TRACE     ') THEN
 657           READ(NUMBER,*) IDEBF,IDLEV
 658           WRITE(LO,*) 'TRACE      ',IDEBF,IDLEV
 659           IDEB(IDEBF) = IDLEV
 660         ELSE IF(CNAME.EQ.'SETICUT   ') THEN
 661           READ(NUMBER,*) I,ICUT
 662           WRITE(LO,*) 'SETICUT    ',I,ICUT
 663           ISWCUT(I) = ICUT
 664         ELSE IF(CNAME.EQ.'SETFCUT   ') THEN
 665           READ(NUMBER,*) I,PARNEW
 666           WRITE(LO,*) 'SETFCUT    ',I,PARNEW
 667           HSWCUT(I) = PARNEW
 668         ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
 669           READ(NUMBER,*) I,IVAL
 670           WRITE(LO,*) 'LUND-MSTU  ',I,IVAL
 671           MSTU(I) = IVAL
 672         ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
 673           READ(NUMBER,*) I,IVAL
 674           WRITE(LO,*) 'LUND-MSTJ  ',I,IVAL
 675           MSTJ(I) = IVAL
 676         ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
 677           READ(NUMBER,*) I,EE
 678           WRITE(LO,*) 'LUND-PARJ  ',I,EE
 679           PARJ(I) = REAL(EE)
 680         ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
 681           READ(NUMBER,*) I,EE
 682           WRITE(LO,*) 'LUND-PARU  ',I,EE
 683           PARU(I) = REAL(EE)
 684         ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
 685           READ(NUMBER,*) ID,ION
 686           WRITE(LO,*) 'LUND-DECAY ',ID,ION
 687
 688           KC=PYCOMP(ID)
 689
 690           MDCY(KC,1) = ION
 691         ELSE IF(CNAME.EQ.'PSOFTMIN  ') THEN
 692           READ(NUMBER,*) PSOMIN
 693           WRITE(LO,*) 'PSOFTMIN   ',PSOMIN
 694         ELSE IF(CNAME.EQ.'INTPREC   ') THEN
 695           READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 696           WRITE(LO,*) 'INTPREC    ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 697
 698 C  PDF test utility
 699         ELSE IF(CNAME.EQ.'PDFTEST   ') THEN
 700           READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
 701           PVIRT2 = ABS(PVIRT2)
 702           WRITE(LO,*) 'PDFTEST   ',IDPDG,' ',SCALE2,' ',PVIRT2
 703           CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
 704
 705 C  mass cut on gamma-gamma or gamma-hadron system
 706         ELSE IF(CNAME.EQ.'ECMS-CUT  ') THEN
 707           READ(NUMBER,*) ECMIN,ECMAX
 708           WRITE(LO,*) 'ECMS-CUT  ',ECMIN,ECMAX
 709
 710 C  beam lepton (anti-)tagging system
 711         ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
 712           READ(NUMBER,*) ITAG1,ITAG2
 713           WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
 714         ELSE IF(CNAME.EQ.'E-TAG1    ') THEN
 715           READ(NUMBER,*)
 716      &      EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
 717           WRITE(LO,*) 'E-TAG1    ',EEMIN1,YMIN1,YMAX1,
 718      &      Q2MIN1,Q2MAX1,THMIN1,THMAX1
 719         ELSE IF(CNAME.EQ.'E-TAG2    ') THEN
 720           READ(NUMBER,*)
 721      &      EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
 722           WRITE(LO,*) 'E-TAG2    ',EEMIN2,YMIN2,YMAX2,
 723      &      Q2MIN2,Q2MAX2,THMIN2,THMAX2
 724
 725 C  sampling of gamma-p events in ep (HERA)
 726         ELSE IF(    (CNAME.EQ.'WW-HERA   ')
 727      &          .OR.(CNAME.EQ.'GP-HERA   ')) THEN
 728           READ(NUMBER,*) EE1,EE2,NEV
 729           WRITE(LO,*) 'GP-HERA   ',EE1,EE2,NEV
 730           IF(YMAX2.LT.0.D0) THEN
 731             WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
 732           ELSE
 733             CALL PHO_GPHERA(NEV,EE1,EE2)
 734             KEVENT = 0
 735           ENDIF
 736
 737 C  sampling of gamma-gamma events in e+e- (LEP)
 738         ELSE IF(    (CNAME.EQ.'GG-EPEM   ')
 739      &          .OR.(CNAME.EQ.'WW-EPEM   ')) THEN
 740           READ(NUMBER,*) EE1,EE2,NEV
 741           WRITE(LO,*) 'GG-EPEM   ',EE1,EE2,NEV
 742           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 743             WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
 744           ELSE
 745             CALL PHO_GGEPEM(-1,EE1,EE2)
 746             CALL PHO_GGEPEM(NEV,EE1,EE2)
 747             CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
 748             KEVENT = 0
 749           ENDIF
 750
 751 C  sampling of gamma-gamma in heavy-ion collisions
 752         ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
 753           READ(NUMBER,*) EE,NA,NZ,NEV
 754           WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
 755           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 756             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 757           ELSE
 758             CALL PHO_GGHIOF(NEV,EE,NA,NZ)
 759             KEVENT = 0
 760           ENDIF
 761         ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
 762           READ(NUMBER,*) EE,NA,NZ,NEV
 763           WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
 764           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 765             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 766           ELSE
 767             CALL PHO_GGHIOG(NEV,EE,NA,NZ)
 768             KEVENT = 0
 769           ENDIF
 770
 771 C  sampling of gamma-hadron events in heavy ion collisions
 772         ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
 773           READ(NUMBER,*) EE,NA,NZ,NEV
 774           WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
 775           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 776             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 777           ELSE
 778             CALL PHO_GHHIOF(NEV,EE,NA,NZ)
 779             KEVENT = 0
 780           ENDIF
 781
 782 C  sampling of hadron-gamma events in hadron - heavy ion collisions
 783         ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
 784           READ(NUMBER,*) EP,EE,NA,NZ,NEV
 785           WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
 786           IF(YMAX2.LT.0.D0) THEN
 787             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 788           ELSE
 789             CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
 790             KEVENT = 0
 791           ENDIF
 792
 793 C  sampling of photoproduction events e+e-, backscattered laser
 794         ELSE IF(CNAME.EQ.'BLASER    ') THEN
 795           READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
 796           WRITE(LO,*) 'BLASER    ',EE1,EE2,
 797      &      Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
 798           CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
 799           KEVENT = 0
 800
 801 C  sampling of photoproduction events beamstrahlung
 802         ELSE IF(CNAME.EQ.'BEAMST    ') THEN
 803           READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
 804           WRITE(LO,*) 'BEAMST    ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
 805           IF(YMAX1.LT.0.D0) THEN
 806             WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
 807           ELSE
 808             CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
 809             KEVENT = 0
 810           ENDIF
 811
 812 C  fixed-energy events in LAB system of particle 2
 813         ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
 814           READ(NUMBER,*) PLAB,NEV
 815           WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
 816           CALL PHO_FIXLAB(PLAB,NEV)
 817           KEVENT = 0
 818
 819 C  fixed-energy events in CM system
 820         ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
 821           READ(NUMBER,*) ECM,NEV
 822           WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
 823           PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
 824           PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
 825           CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
 826           E1 = EE
 827           E2 = ECM-EE
 828           THETA = 0.D0
 829           PHI   = 0.D0
 830           CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
 831           KEVENT = 0
 832
 833 C  fixed-energy events for collider setup with crossing angle
 834         ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
 835           READ(NUMBER,*) E1,E2,THETA,PHI,NEV
 836           WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
 837           CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
 838           KEVENT = 0
 839
 840 C  unknown data card
 841         ELSE
 842           WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
 843         ENDIF
 844
 845       GOTO 1200
 846  1300 CONTINUE
 847       WRITE(LO,*) ' RETURN'
 848
 849       END
 850
 851 *$ CREATE PHO_SETMDL.FOR
 852 *COPY PHO_SETMDL
 853 CDECK  ID>, PHO_SETMDL
 854       SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
 855 C**********************************************************************
 856 C
 857 C     set model switches
 858 C
 859 C     input:  INDX       model parameter number
 860 C                        (positive: ISWMDL, negative: IPAMDL)
 861 C             IVAL       new value
 862 C             IMODE      -1  print value of parameter INDX
 863 C                        1   set new value
 864 C                        -2  print current settings
 865 C
 866 C**********************************************************************
 867       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
 868       SAVE
 869
 870 C  input/output channels
 871       INTEGER LI,LO
 872       COMMON /POINOU/ LI,LO
 873 C  model switches and parameters
 874       CHARACTER*8 MDLNA
 875       INTEGER ISWMDL,IPAMDL
 876       DOUBLE PRECISION PARMDL
 877       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
 878
 879       IF(IMODE.EQ.-2) THEN
 880         WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
 881      &                             '----------------------------'
 882         DO 100 I=1,48,3
 883           IF(ISWMDL(I).EQ.-9999) GOTO 200
 884           IF(ISWMDL(I+1).EQ.-9999) THEN
 885             WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
 886             GOTO 200
 887           ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
 888             WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
 889      &        I+1,':',MDLNA(I+1),ISWMDL(I+1)
 890             GOTO 200
 891           ELSE
 892             WRITE(LO,'(3(5X,I3,A1,A,I6))')
 893      &        (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
 894           ENDIF
 895  100    CONTINUE
 896  200    CONTINUE
 897       ELSE IF(IMODE.EQ.-1) THEN
 898         WRITE(LO,'(1X,A,1X,A,I6)')
 899      &    'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
 900       ELSE IF(IMODE.EQ.1) THEN
 901         IF(INDX.GT.0) THEN
 902           IF(ISWMDL(INDX).NE.IVAL) THEN
 903             WRITE(LO,'(1X,A,I4,1X,A,2I6)')
 904      &        'PHO_SETMDL:ISWMDL(OLD/NEW):',
 905      &        INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
 906             ISWMDL(INDX) = IVAL
 907           ENDIF
 908         ELSE IF(INDX.LT.0) THEN
 909           IF(IPAMDL(-INDX).NE.IVAL) THEN
 910             WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
 911      &        -INDX,IPAMDL(-INDX),IVAL
 912             IPAMDL(-INDX) = IVAL
 913           ENDIF
 914         ENDIF
 915       ELSE
 916         WRITE(LO,'(/1X,A,I6)')
 917      &    'PHO_SETMDL:ERROR: unsupported mode',IMODE
 918       ENDIF
 919       END
 920
 921 *$ CREATE PHO_DATINI.FOR
 922 *COPY PHO_DATINI
 923 CDECK  ID>, PHO_DATINI
 924       SUBROUTINE PHO_DATINI
 925 C*********************************************************************
 926 C
 927 C     initialization of variables and switches
 928 C
 929 C*********************************************************************
 930       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
 931       SAVE
 932
 933 C  input/output channels
 934       INTEGER LI,LO
 935       COMMON /POINOU/ LI,LO
 936 C  some constants
 937       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
 938       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
 939      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
 940 C  event debugging information
 941       INTEGER NMAXD
 942       PARAMETER (NMAXD=100)
 943       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
 944      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 945       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
 946      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 947 C  event weights and generated cross section
 948       INTEGER IPOWGC,ISWCUT,IVWGHT
 949       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
 950       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
 951      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
 952 C  scale parameters for parton model calculations
 953       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
 954       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
 955       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
 956      &                NQQAL,NQQALI,NQQALF,NQQPD
 957 C  integration precision for hard cross sections (obsolete)
 958       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 959       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 960 C  hard scattering parameters used for most recent hard interaction
 961       INTEGER NFbeta,NF
 962       DOUBLE PRECISION ALQCD2,BQCD
 963       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
 964 C  cut probability distribution
 965       INTEGER IEETA1,IIMAX,KKMAX
 966       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
 967       INTEGER IEEMAX,IMAX,KMAX
 968       REAL PROB
 969       DOUBLE PRECISION EPTAB
 970       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
 971      &                IEEMAX,IMAX,KMAX
 972 C  gamma-lepton or gamma-hadron vertex information
 973       INTEGER IGHEL,IDPSRC,IDBSRC
 974       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
 975      &                 RADSRC,AMSRC,GAMSRC
 976       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
 977      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
 978      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
 979 C  photon flux kinematics and cuts
 980       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
 981      &                 YMIN1,YMAX1,YMIN2,YMAX2,
 982      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 983      &                 THMIN1,THMAX1,THMIN2,THMAX2
 984       INTEGER          ITAG1,ITAG2
 985       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
 986      &                YMIN1,YMAX1,YMIN2,YMAX2,
 987      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 988      &                THMIN1,THMAX1,THMIN2,THMAX2,
 989      &                ITAG1,ITAG2
 990 C  obsolete cut-off information
 991       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
 992       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
 993 C  global event kinematics and particle IDs
 994       INTEGER IFPAP,IFPAB
 995       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
 996       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
 997 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
 998       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
 999       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
1000       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
1001      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
1002 C  some hadron information, will be deleted in future versions
1003       INTEGER NFS
1004       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
1005       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
1006 C  model switches and parameters
1007       CHARACTER*8 MDLNA
1008       INTEGER ISWMDL,IPAMDL
1009       DOUBLE PRECISION PARMDL
1010       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
1011 C  general process information
1012       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
1013       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
1014 C  parameters of the "simple" Vector Dominance Model
1015       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
1016       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
1017 C  parameters for DGLAP backward evolution in ISR
1018       INTEGER NFSISR
1019       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
1020       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
1021 C  particles created by initial state evolution
1022       INTEGER MXISR1,MXISR2
1023       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
1024       INTEGER IFLISR,IPOISR,IMXISR
1025       DOUBLE PRECISION PHISR
1026       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
1027      &                IPOISR(2,2,MXISR2),IMXISR(2)
1028 C  names of hard scattering processes
1029       INTEGER Max_pro_1
1030       PARAMETER ( Max_pro_1 = 16 )
1031       CHARACTER*18 PROC
1032       COMMON /POHPRO/ PROC(0:Max_pro_1)
1033 C  hard cross sections and MC selection weights
1034       INTEGER Max_pro_2
1035       PARAMETER ( Max_pro_2 = 16 )
1036       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
1037      &  MH_acc_1,MH_acc_2
1038       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
1039       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
1040      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
1041      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
1042      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
1043      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
1044 C  interpolation tables for hard cross section and MC selection weights
1045       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
1046       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
1047       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
1048       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
1049      &  HQ2a_tab,HQ2b_tab,HEcm_tab
1050       COMMON /POHTAB/
1051      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1052      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1053      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1054      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1055      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
1056      &  HEcm_tab(1:Max_tab_E,0:4),
1057      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
1058
1059 C  initialize /POCONS/
1060       PI   = ATAN(1.D0)*4.D0
1061       PI2  = 2.D0*PI
1062       PI4  = 2.D0*PI2
1063 C  GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
1064       GEV2MB = 0.389365D0
1065 C  precalculate quark charges
1066       do i=1,6
1067         Q_ch(i) = dble(2-3*mod(i,2))/3.D0
1068         Q_ch(-i) = -Q_ch(i)
1069
1070         Q_ch2(i) = Q_ch(i)**2
1071         Q_ch2(-i) = Q_ch2(i)
1072
1073         Q_ch4(i) = Q_ch2(i)**2
1074         Q_ch4(-i) = Q_ch4(i)
1075       enddo
1076       Q_ch(0)  = 0.D0
1077       Q_ch2(0) = 0.D0
1078       Q_ch4(0) = 0.D0
1079
1080 C  initialize /GLOCMS/
1081       ECM    = 50.D0
1082       PMASS(1) = 0.D0
1083       PVIRT(1) = 0.D0
1084       PMASS(2) = 0.D0
1085       PVIRT(2) = 0.D0
1086       IFPAP(1) = 22
1087       IFPAP(2) = 22
1088 C  initialize /HADVAL/
1089       IHFLD(1,1) = 0
1090       IHFLD(1,2) = 0
1091       IHFLD(2,1) = 0
1092       IHFLD(2,2) = 0
1093       IHFLS(1) = 1
1094       IHFLS(2) = 1
1095 C  initialize /MODELS/
1096       ISWMDL(1)  = 3
1097       MDLNA(1)  = 'AMPL MOD'
1098       ISWMDL(2)  = 1
1099       MDLNA(2)  = 'MIN-BIAS'
1100       ISWMDL(3)  = 1
1101       MDLNA(3)  = 'PTS DISH'
1102       ISWMDL(4)  = 1
1103       MDLNA(4)  = 'PTS DISP'
1104       ISWMDL(5)  = 2
1105       MDLNA(5)  = 'PTS ASSI'
1106       ISWMDL(6)  = 3
1107       MDLNA(6)  = 'HADRONIZ'
1108       ISWMDL(7)  = 2
1109       MDLNA(7)  = 'MASS COR'
1110       ISWMDL(8)  = 3
1111       MDLNA(8)  = 'PAR SHOW'
1112       ISWMDL(9)  = 0
1113       MDLNA(9)  = 'GLU SPLI'
1114       ISWMDL(10) = 2
1115       MDLNA(10) = 'VIRT PHO'
1116       ISWMDL(11) = 0
1117       MDLNA(11) = 'LARGE NC'
1118       ISWMDL(12) = 0
1119       MDLNA(12) = 'LIPA POM'
1120       ISWMDL(13) = 1
1121       MDLNA(13) = 'QELAS VM'
1122       ISWMDL(14) = 2
1123       MDLNA(14) = 'ENHA GRA'
1124       ISWMDL(15) = 4
1125       MDLNA(15) = 'MULT SCA'
1126       ISWMDL(16) = 4
1127       MDLNA(16) = 'MULT DIF'
1128       ISWMDL(17) = 4
1129       MDLNA(17) = 'MULT CDF'
1130       ISWMDL(18) = 0
1131       MDLNA(18) = 'BALAN PT'
1132       ISWMDL(19) = 1
1133       MDLNA(19) = 'POMV FLA'
1134       ISWMDL(20) = 0
1135       MDLNA(20) = 'SEA  FLA'
1136       ISWMDL(21) = 2
1137       MDLNA(21) = 'SPIN DEC'
1138       ISWMDL(22) = 1
1139       MDLNA(22) = 'DIF.MASS'
1140       ISWMDL(23) = 1
1141       MDLNA(23) = 'DIFF RES'
1142       ISWMDL(24) = 0
1143       MDLNA(24) = 'PTS HPOM'
1144       ISWMDL(25) = 0
1145       MDLNA(25) = 'POM CORR'
1146       ISWMDL(26) = 1
1147       MDLNA(26) = 'OVERLAP '
1148       ISWMDL(27) = 0
1149       MDLNA(27) = 'MUL R/AN'
1150       ISWMDL(28) = 1
1151       MDLNA(28) = 'SUR PROB'
1152       ISWMDL(29) = 1
1153       MDLNA(29) = 'PRIMO KT'
1154       ISWMDL(30) = 0
1155       MDLNA(30) = 'DIFF. CS'
1156       ISWMDL(31) = -9999
1157 C  mass-independent sea flavour ratios (for low-mass strings)
1158       PARMDL(1)  = 0.425D0
1159       PARMDL(2)  = 0.425D0
1160       PARMDL(3)  = 0.15D0
1161       PARMDL(4)  = 0.D0
1162       PARMDL(5)  = 0.D0
1163       PARMDL(6)  = 0.D0
1164 C  suppression by energy momentum conservation
1165       PARMDL(8)  = 9.D0
1166       PARMDL(9)  = 7.D0
1167 C  VDM factors
1168       PARMDL(10) = 0.866D0
1169       PARMDL(11) = 0.288D0
1170       PARMDL(12) = 0.288D0
1171       PARMDL(13) = 0.288D0
1172       PARMDL(14) = 0.866D0
1173       PARMDL(15) = 0.288D0
1174       PARMDL(16) = 0.288D0
1175       PARMDL(17) = 0.288D0
1176       PARMDL(18) = 0.D0
1177 C  lower energy limit for initialization
1178       PARMDL(19) = 5.D0
1179 C  soft pt for hard scattering remnants
1180       PARMDL(20) = 5.D0
1181 C  low energy beta of soft pt distribution 1
1182       PARMDL(21) = 4.5D0
1183 C  high energy beta of soft pt distribution 1
1184       PARMDL(22) = 3.0D0
1185 C  low energy beta of soft pt distribution 0
1186       PARMDL(23) = 2.5D0
1187 C  high energy beta of soft pt distribution 0
1188       PARMDL(24) = 0.4D0
1189 C  effective quark mass in photon wave function
1190       PARMDL(25) = 0.2D0
1191 C  normalization of unevolved Pomeron PDFs
1192       PARMDL(26) = 0.3D0
1193 C  effective VDM parameters for Q**2 dependence of cross section
1194       PARMDL(27) = 0.65D0
1195       PARMDL(28) = 0.08D0
1196       PARMDL(29) = 0.05D0
1197       PARMDL(30) = 0.22D0
1198       PARMDL(31) = 0.589824D0
1199       PARMDL(32) = 0.609961D0
1200       PARMDL(33) = 1.038361D0
1201       PARMDL(34) = 1.96D0
1202 C  Q**2 suppression of multiple interactions
1203       PARMDL(35) = 0.59D0
1204 C  pt cutoff defaults
1205       PARMDL(36) = 2.5D0
1206       PARMDL(37) = 2.5D0
1207       PARMDL(38) = 2.5D0
1208       PARMDL(39) = 2.5D0
1209 C  enhancement factor for diffractive cross sections
1210       PARMDL(40) = 1.D0
1211       PARMDL(41) = 1.D0
1212       PARMDL(42) = 1.D0
1213 C  mass in soft pt distribution
1214       PARMDL(43) = 0.D0
1215 C  maximum of x allowed for leading particle
1216       PARMDL(44) = 0.9D0
1217 C  max. mass sampled in diffraction
1218       PARMDL(45) = sqrt(0.4D0)
1219 C  mass threshold in diffraction (2pi mass)
1220       PARMDL(46) = 0.3D0
1221 C  regularization of slope parameter in diffraction
1222       PARMDL(47) = 4.D0
1223 C  renormalized intercept for enhanced graphs
1224       PARMDL(48) = 1.08D0
1225 C  coherence constraint for diff. cross sections
1226       PARMDL(49) = sqrt(0.05D0)
1227 C  exponents of x distributions
1228 C  baryon
1229       PARMDL(50) = 1.5D0
1230       PARMDL(51) = -0.5D0
1231       PARMDL(52) = -0.99D0
1232       PARMDL(53) = -0.99D0
1233 C  meson (non-strangeness part)
1234       PARMDL(54) = -0.5D0
1235       PARMDL(55) = -0.5D0
1236       PARMDL(56) = -0.99D0
1237       PARMDL(57) = -0.99D0
1238 C  meson (strangeness part)
1239       PARMDL(58) = -0.2D0
1240       PARMDL(59) = -0.2D0
1241       PARMDL(60) = -0.99D0
1242       PARMDL(61) = -0.99D0
1243 C  particle remnant (no valence quarks)
1244       PARMDL(62) = -0.5D0
1245       PARMDL(63) = -0.5D0
1246       PARMDL(64) = -0.99D0
1247       PARMDL(65) = -0.99D0
1248 C  ratio beetween triple-pomeron/reggeon couplings grrp/gppp
1249       PARMDL(66) = 10.D0
1250 C  ratio beetween triple-pomeron/reggeon couplings gppr/gppp
1251       PARMDL(67) = 10.D0
1252 C  min. abs(t) in diffraction
1253       PARMDL(68) = 0.D0
1254 C  max. abs(t) in diffraction
1255       PARMDL(69) = 10.D0
1256 C  min. mass for elastic pomerons in central diffraction
1257       PARMDL(70) = 2.D0
1258 C  min. mass of diffractive blob in central diffraction
1259       PARMDL(71) = 2.D0
1260 C  min. Feynman x cut in central diffraction
1261       PARMDL(72) = 0.D0
1262 C  direct pomeron coupling
1263       PARMDL(74) = 0.D0
1264 C  relative deviation allowed for energy-momentum conservation
1265 C  energy-momentum relative deviation
1266       PARMDL(75) = 0.01D0
1267 C  transverse momentum deviation
1268       PARMDL(76) = 0.01D0
1269 C  couplings for unitarization in diffraction
1270 C  non-unitarized pomeron coupling (sqrt(mb))
1271       PARMDL(77)  = 3.D0
1272 C  rescaling factor for pomeron PDF
1273       PARMDL(78)  = 3.D0
1274 C  coupling probabilities
1275       PARMDL(79)  = 1.D0
1276       PARMDL(80)  = 0.D0
1277 C  scales to calculate alpha-s of matrix element
1278       PARMDL(81) = 1.D0
1279       PARMDL(82) = 1.D0
1280       PARMDL(83) = 1.D0
1281 C  scales to calculate alpha-s of initial state radiation
1282       PARMDL(84) = 1.D0
1283       PARMDL(85) = 1.D0
1284       PARMDL(86) = 1.D0
1285 C  scales to calculate alpha-s of final state radiation
1286       PARMDL(87) = 1.D0
1287       PARMDL(88) = 1.D0
1288       PARMDL(89) = 1.D0
1289 C  scales to calculate PDFs
1290       PARMDL(90) = 1.D0
1291       PARMDL(91) = 1.D0
1292       PARMDL(92) = 1.D0
1293 C  scale for ISR starting virtuality
1294       PARMDL(93) = 1.D0
1295 C  min. virtuality to generate time-like showers in ISR
1296       PARMDL(94) = 2.D0
1297 C  factor to scale the max. allowed time-like parton shower virtuality
1298       PARMDL(95) = 4.D0
1299 C  max. transverse momentum for primordial kt
1300       PARMDL(100) = 2.D0
1301 C  weight factors for pt-distribution
1302       PARMDL(101) = 2.D0
1303       PARMDL(102) = 2.D0
1304       PARMDL(103) = 4.D0
1305       PARMDL(104) = 2.D0
1306       PARMDL(105) = 6.D0
1307       PARMDL(106) = 4.D0
1308 C
1309 *     PARMDL(110-125)  reserved for hard scattering
1310 C  currently chosen scales for hard scattering
1311       DO 10 I=1,16
1312         PARMDL(109+I) = 0.D0
1313  10   CONTINUE
1314 C  virtuality cutoff in initial state evolution
1315       PARMDL(126) = PARMDL(36)**2
1316       PARMDL(127) = PARMDL(37)**2
1317       PARMDL(128) = PARMDL(38)**2
1318       PARMDL(129) = PARMDL(39)**2
1319 C  virtuality cutoff for direct contribution to photon PDF
1320       PARMDL(130) = 1.D30
1321       PARMDL(131) = 1.D30
1322       PARMDL(132) = 1.D30
1323       PARMDL(133) = 1.D30
1324 C  fraction of events without popcorn
1325       PARMDL(134) = -1.D0
1326 C  fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
1327       PARMDL(135) = 0.5D0
1328 C  soft color re-connection (fraction)
1329 C  g g final state
1330       PARMDL(140) = 1.D0/64.D0
1331 C  g q final state
1332       PARMDL(141) = 1.D0/24.D0
1333 C  q q final state
1334       PARMDL(142) = 1.D0/9.D0
1335 C  effective scale in Drees-Godbole like suppresion in photon PDF
1336       PARMDL(144) = 0.766D0**2
1337 C  QCD scales (if PDF scales are not used, 4 active flavours)
1338       PARMDL(145) = 0.2D0**2
1339       PARMDL(146) = 0.2D0**2
1340       PARMDL(147) = 0.2D0**2
1341 C  threshold scales for variable flavour calculation (GeV**2)
1342       PARMDL(148) = 1.5D0**2
1343       PARMDL(149) = 4.5D0**2
1344       PARMDL(150) = 175.D0**2
1345 C  constituent quark masses
1346       PARMDL(151) = 0.3D0
1347       PARMDL(152) = 0.3D0
1348       PARMDL(153) = 0.5D0
1349       PARMDL(154) = 1.6D0
1350       PARMDL(155) = 5.D0
1351       PARMDL(156) = 174.D0
1352 C  min. masses of valence quark
1353       PARMDL(157) = 0.3D0
1354 C  min. masses of valence diquark
1355       PARMDL(158) = 0.8D0
1356 C  min. mass of sea quark
1357       PARMDL(159) = 0.D0
1358 C  suppression of strange quarks as photon valences
1359       PARMDL(160) = 0.2D0
1360 C  min. masses for strings (used in PHO_SOFTXX)
1361       PARMDL(161) = 1.D0
1362       PARMDL(162) = 1.D0
1363       PARMDL(163) = 1.D0
1364       PARMDL(164) = 1.D0
1365 C  min. momentum fraction for soft processes
1366       PARMDL(165) = 0.3D0
1367 C  min. phase space for x-sampling
1368       PARMDL(166) = 0.135D0
1369 C  Ross-Stodolsky exponent
1370       PARMDL(170) = 4.2D0
1371 C  cutoff on photon-pomeron invariant mass in hadron-hadron collisions
1372       PARMDL(175) = 2.D0
1373
1374 **sr
1375 *  extra factor multiplying difference between Goulianos and PHOJET-
1376 *  diff. cross sections
1377       PARMDL(200) = 0.6D0
1378 **
1379
1380 C  complex amplitudes, eikonal functions
1381       IPAMDL(1)  = 0
1382 C  allow for Reggeon cuts
1383       IPAMDL(2)  = 1
1384 C  decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
1385       IPAMDL(3)  = 0
1386 C  polarization of photon resonances (0 none, 1 trans, 2 long)
1387       IPAMDL(4)  = 1
1388 C  pt of valence partons
1389       IPAMDL(5)  = 1
1390 C  pt of hard scattering remnant
1391       IPAMDL(6)  = 2
1392 C  running cutoff for hard scattering
1393       IPAMDL(7)  = 1
1394 C  intercept used for the calculation of enhanced graphs
1395       IPAMDL(8)  = 1
1396 C  effective slope of hard scattering amplitde
1397       IPAMDL(9)  = 1
1398 C  mass dependence of slope parameters
1399       IPAMDL(10) = 0
1400 C  lepton-photon vertex 1
1401       IPAMDL(11) = 0
1402 C  lepton-photon vertex 2
1403       IPAMDL(12) = 0
1404 C  call by DPMJET
1405       IPAMDL(13) = 0
1406 C  method to sample x distributions
1407       IPAMDL(14) = 3
1408 C  energy-momentum check
1409       IPAMDL(15) = 1
1410 C  phase space correction for DPMJET interface
1411       IPAMDL(16) = 1
1412 C  fragment strings from projectile/target/central diff. separately
1413       IPAMDL(17) = 1
1414 C  method to construct strings for hard interactions
1415       IPAMDL(18) = 1
1416 C  method to construct strings for soft sea (pomeron cuts)
1417       IPAMDL(19) = 0
1418 C  method to construct strings in pomeron interactions
1419       IPAMDL(20) = 0
1420 C  soft color re-connection
1421       IPAMDL(21) = 0
1422 C  resummation of triple- and loop-Pomeron
1423       IPAMDL(24) = 1
1424 C  resummation of X iterated triple-Pomeron
1425       IPAMDL(25) = 1
1426 C  dimension of interpolation table for weights in hard scattering
1427       IPAMDL(30) = Max_tab_E
1428 C  dimension of interpolation table for pomeron cut distribution
1429       IPAMDL(31) = IEETA1
1430 C  number of cut soft pomerons (restriction by field dimension)
1431       IPAMDL(32) = IIMAX
1432 C  number of cut hard pomerons (restriction by field dimension)
1433       IPAMDL(33) = KKMAX
1434 C  tau pair production in direct photon-photon collisions
1435       IPAMDL(64) = 0
1436 C  currently chosen scales for hard scattering
1437 C  ATTENTION:   IPAMDL(65-80)  reserved for hard scattering!
1438       DO 15 I=1,16
1439         IPAMDL(64+I) = -99999
1440  15   CONTINUE
1441 C  scales to calculate alpha-s of matrix element
1442       IPAMDL(81) = 1
1443       IPAMDL(82) = 1
1444       IPAMDL(83) = 1
1445 C  scales to calculate alpha-s of initial state radiation
1446       IPAMDL(84) = 1
1447       IPAMDL(85) = 1
1448       IPAMDL(86) = 1
1449 C  scales to calculate alpha-s of final state radiation
1450       IPAMDL(87) = 1
1451       IPAMDL(88) = 1
1452       IPAMDL(89) = 1
1453 C  scales to calculate PDFs
1454       IPAMDL(90) = 1
1455       IPAMDL(91) = 1
1456       IPAMDL(92) = 1
1457 C  where to get the parameter sets from
1458       IPAMDL(99) = 1
1459 C  program PHO_ABORT for fatal errors (simulation of division by zero)
1460       IPAMDL(100) = 0
1461 C  initial state parton showers for all / hardest interaction(s)
1462       IPAMDL(101) = 1
1463 C  final state parton showers for all / hardest interaction(s)
1464       IPAMDL(102) = 1
1465 C  initial virtuality for ISR generation
1466       IPAMDL(109) = 1
1467 C  qqbar-gamma coupling in initial state showers
1468       IPAMDL(110) = 1
1469 C  generation of time-like showers during ISR
1470       IPAMDL(111) = 1
1471 C  reweighting of multiple soft contributions for virtual photons
1472       IPAMDL(114) = 1
1473 C  reweighting / use photon virtuality in photon PDF calculations
1474       IPAMDL(115) = 0
1475 C  use full QPM model incl. interference terms (direct part in gam-gam)
1476       IPAMDL(116) = 0
1477 C  matching sigma_tot to F2 as given by parton density at high Q2
1478       IPAMDL(117) = 1
1479 C  use virtuality of target in F2 calculations (two-gamma only)
1480       IPAMDL(118) = 1
1481 C  calculation of alpha_em
1482       IPAMDL(120) = 1
1483 C  strict pt cutoff for gamma-gamma events
1484       IPAMDL(121) = 0
1485 C  photon virtuality sampled in photon flux approximations
1486       IPAMDL(174) = 1
1487 C  photon-pomeron: 0,1,2: both,left,right photon emission
1488       IPAMDL(175) = 0
1489 C  keep full history information in PHOJET-JETSET interface
1490       IPAMDL(178) = 1
1491 C  max. number of conservation law violations allowed in one run
1492       IPAMDL(179) = 20
1493 C  selection of soft X values
1494 C  max. iteration number in PHO_SELSXS
1495       IPAMDL(180) = 50
1496 C  max. iteration number in PHO_SELSXR
1497       IPAMDL(181) = 200
1498 C  max. iteration number in PHO_SELSX2
1499       IPAMDL(182) = 100
1500 C  max. iteration number in PHO_SELSXI
1501       IPAMDL(183) = 50
1502
1503 C  initialize /PROBAB/
1504       IEEMAX = IEETA1
1505       IMAX   = IIMAX
1506       KMAX   = KKMAX
1507
1508       DO 20 I=1,30
1509         PARMDL(300+I) = -100000.D0
1510  20   CONTINUE
1511 C  initialize /POHDRN/
1512       QMASS(1) =  PARMDL(151)
1513       QMASS(2) =  PARMDL(152)
1514       QMASS(3) =  PARMDL(153)
1515       QMASS(4) =  PARMDL(154)
1516       QMASS(5) =  PARMDL(155)
1517       QMASS(6) =  PARMDL(156)
1518       BET      = 8.D0
1519       PCOUDI   = 0.D0
1520       VALPRG(1) = 1.D0
1521       VALPRG(2) = 1.D0
1522 C  number of light flavours (quarks treated as massless)
1523       NFS      = 4
1524 C  initialize /POCUT1/
1525       PTCUT(1) = PARMDL(36)
1526       PTCUT(2) = PARMDL(37)
1527       PTCUT(3) = PARMDL(38)
1528       PTCUT(4) = PARMDL(39)
1529       PSOMIN = 0.D0
1530       XSOMIN = 0.D0
1531 C  initialize /POHAPA/
1532       NFbeta  = 4
1533       NF      = 4
1534       BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
1535       BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
1536       BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
1537       BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
1538 C  initialize /POGAUP/
1539       NGAUP1 = 12
1540       NGAUP2 = 12
1541       NGAUET = 16
1542       NGAUIN = 12
1543       NGAUSO = 96
1544 C  initialize //
1545       DO 30 I=1,100
1546         IDEB(I) = 0
1547  30   CONTINUE
1548 C  initialize /PROCES/
1549       DO 35 I=1,11
1550         IPRON(I,1) = 1
1551  35   CONTINUE
1552
1553 C  DPMJET default: no elastic scattering
1554       IPRON(2,1) = 0
1555
1556       DO 36 K=2,4
1557         DO 37 I=2,11
1558           IPRON(I,K) = 0
1559  37     CONTINUE
1560         IPRON(1,K) = 1
1561         IPRON(8,K) = 1
1562  36   CONTINUE
1563 C  initialize /POSVDM/
1564       TWOPIM = 0.28D0
1565       RMIN(1) = 0.285D0
1566       RMIN(2) = 0.45D0
1567       RMIN(3) = 1.D0
1568       RMIN(4) = TWOPIM
1569       VMAS(1) = 0.770D0
1570       VMAS(2) = 0.787D0
1571       VMAS(3) = 1.02D0
1572       VMAS(4) = TWOPIM
1573       GAMM(1) = 0.155D0
1574       GAMM(2) = 0.01D0
1575       GAMM(3) = 0.0045D0
1576       GAMM(4) = 1.D0
1577       RMAX(1) = VMAS(1)+TWOPIM
1578       RMAX(2) = VMAS(2)+TWOPIM
1579       RMAX(3) = VMAS(3)+TWOPIM
1580       RMAX(4) = VMAS(1)+TWOPIM
1581       VMSL(1) = 11.D0
1582       VMSL(2) = 10.D0
1583       VMSL(3) = 6.D0
1584       VMSL(4) = 4.D0
1585       VMFA(1) = 0.0033D0
1586       VMFA(2) = 0.00036D0
1587       VMFA(3) = 0.0002D0
1588       VMFA(4) = 0.0002D0
1589 C  initialize /PODGL1/
1590       Q2MISR(1) = PARMDL(36)**2
1591       Q2MISR(2) = PARMDL(36)**2
1592       PMISR(1) = 1.D0
1593       PMISR(2) = 1.D0
1594       ZMISR(1) = 0.001D0
1595       ZMISR(2) = 0.001D0
1596       AL2ISR(1) = 0.046D0
1597       AL2ISR(2) = 0.046D0
1598       NFSISR  = 4
1599 C  initialize /POPISR/
1600       DO 40 I=1,50
1601         IPOISR(1,2,I) = 0
1602         IPOISR(2,2,I) = 0
1603  40   CONTINUE
1604 C  initialize /POHPRO/
1605       PROC(0) = 'sum over processes'
1606       PROC(1) = 'G  +G  --> G  +G  '
1607       PROC(2) = 'Q  +QB --> G  +G  '
1608       PROC(3) = 'G  +Q  --> G  +Q  '
1609       PROC(4) = 'G  +G  --> Q  +QB '
1610       PROC(5) = 'Q  +QB --> Q  +QB '
1611       PROC(6) = 'Q  +QB --> QP +QBP'
1612       PROC(7) = 'Q  +Q  --> Q  +Q  '
1613       PROC(8) = 'Q  +QP --> Q  +QP '
1614       PROC(9) = 'resolved processes'
1615       PROC(10) = 'gam+Q  --> G  +Q  '
1616       PROC(11) = 'gam+G  --> Q  +QB '
1617       PROC(12) = 'Q  +gam--> G  +Q  '
1618       PROC(13) = 'G  +gam--> Q  +QB '
1619       PROC(14) = 'gam+gam--> Q  +QB '
1620       PROC(15) = 'direct processes  '
1621       PROC(16) = 'gam+gam--> l+ +l- '
1622
1623 C  initialize /POHRCS/
1624       do M=1,Max_pro_2
1625         HWgx(M) = 0.D0
1626         HSig(M) = 0.D0
1627         Hdpt(M) = 0.D0
1628       enddo
1629       DO I=0,4
1630         DO M=-1,Max_pro_2
1631 C  switch all hard subprocesses on
1632           MH_pro_on(M,I) = 1
1633 C  reset all counters
1634           MH_tried(M,I) = 0
1635           MH_acc_1(M,I) = 0
1636           MH_acc_2(M,I) = 0
1637         ENDDO
1638         MH_pro_on(16,I) = 0
1639       ENDDO
1640
1641 C  initialize /POHTAB/
1642       do I=0,4
1643         IH_Ecm_up(I) = 0
1644         IH_Q2a_up(I) = 0
1645         IH_Q2b_up(I) = 0
1646         HEcm_tab(1,I) = 0.D0
1647       enddo
1648       HEcm_last = 0.D0
1649       IHa_last = 0.D0
1650       IHb_last = 0.D0
1651
1652 C  initialize /POFSRC/
1653       IGHEL(1) = -1
1654       IGHEL(2) = -1
1655 C  initialize /LEPCUT/
1656       ECMIN = 5.D0
1657       ECMAX = 1.D+30
1658       EEMIN1 = 1.D0
1659       EEMIN2 = 1.D0
1660       YMAX1 = -1.D0
1661       YMAX2 = -1.D0
1662       THMIN1 = 0.D0
1663       THMAX1 = PI
1664       THMIN2 = 0.D0
1665       THMAX2 = PI
1666       ITAG1 = 1
1667       ITAG2 = 1
1668 C  initialize /POWGHT/
1669       DO 70 I=1,20
1670         HSWCUT(I) = 0.D0
1671         ISWCUT(I) = 0
1672  70   CONTINUE
1673       EVWGHT(1) = 1.D0
1674       IVWGHT(1) = 0
1675       SIGGEN(1) = 0.D0
1676       SIGGEN(2) = 0.D0
1677       SIGGEN(3) = 0.D0
1678       SIGGEN(4) = 0.D0
1679
1680       END
1681
1682 *$ CREATE PHO_PARDAT.FOR
1683 *COPY PHO_PARDAT
1684 CDECK  ID>, PHO_PARDAT
1685       SUBROUTINE PHO_PARDAT
1686 C***********************************************************************
1687 C
1688 C     particle data (based on 1996 PDG naming scheme and data tables)
1689 C
1690 C***********************************************************************
1691
1692       IMPLICIT NONE
1693
1694       SAVE
1695
1696 C  input/output channels
1697       INTEGER LI,LO
1698       COMMON /POINOU/ LI,LO
1699 C  event debugging information
1700       INTEGER NMAXD
1701       PARAMETER (NMAXD=100)
1702       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
1703      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
1704       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
1705      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
1706 C  particle ID translation table
1707       integer         ID_pdg_list,ID_list,ID_pdg_max
1708       character*12    name_list
1709       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
1710      &                ID_pdg_max
1711 C  general particle data
1712       double precision xm_list,tau_list,gam_list,
1713      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
1714      &  xm_bb82_list,xm_bb102_list
1715       integer          ich3_list,iba3_list,iq_list,
1716      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
1717       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
1718      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
1719      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
1720      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
1721      &  ich3_list(300),iba3_list(300),iq_list(3,300),
1722      &  id_psm_list(6,6),id_vem_list(6,6),
1723      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
1724 C  particle decay data
1725       double precision wg_sec_list
1726       integer          idec_list,isec_list
1727       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
1728      &  isec_list(3,500)
1729
1730 C  external functions
1731
1732       integer ipho_pdg2id
1733       double precision pho_pmass
1734
1735 C  local variables for storing data tables
1736
1737       integer number,ich3,iba3,iq_linear,idec_linear,isec_linear,
1738      &  id_psm_linear,id_vem_linear,id_b8_linear,id_b10_linear
1739
1740       dimension number(300),ich3(300),iba3(300),iq_linear(900),
1741      &  idec_linear(900),isec_linear(900),id_psm_linear(36),
1742      &  id_vem_linear(36),id_b8_linear(216),id_b10_linear(216)
1743
1744       double precision xmass,gamma,wg_chan
1745       dimension xmass(300),gamma(300),wg_chan(300)
1746
1747       character*12 name
1748       dimension name(300)
1749
1750       integer i,i1,i2,ii,j,jj,k,l,ichan,i_tab_max,K8,K10,L8,L10
1751       double precision AM1,AM2,AM2P,AM2V,AM82,AM102,AMM
1752
1753       integer itmp
1754
1755       DATA i_tab_max /260/
1756
1757       DATA (number(K),K=    1,  171) /
1758      &     1,     2,     3,     4,     5,     6,  1103,  2101,  2103,
1759      &  2203,  3101,  3103,  3201,  3203,  3303,  4101,  4103,  4201,
1760      &  4203,  4301,  4303,  4403,    81,    82,    90,    91,    92,
1761      &   110,   990,    21,    22,    24,    23,    11,    13,    15,
1762      &    12,    14,    16,   211,   111,   221,   113,   213,   223,
1763      &   331, 10221, 10111, 10211,   333, 10223, 10113, 10213, 20113,
1764      & 20213,   225, 20223, 20221, 20111, 20211,   115,   215, 30223,
1765      & 50223, 40113, 40213, 50221,   335, 60223,   227, 10115, 10215,
1766      & 10333,   117,   217, 30113, 30213, 60221,   337, 20225,   229,
1767      & 30225, 40225,   321,   311,   310,   130,   323,   313, 10313,
1768      & 10323, 20313, 20323, 30313, 30323, 10311, 10321,   325,   315,
1769      & 40313, 40323, 10315, 10325,   317,   327, 20315, 20325,   319,
1770      &   329,   411,   421,   423,   413, 10423,   425,   415,   431,
1771      &   433, 10433,   521,   511,   513,   523,   531,   441,   443,
1772      & 10441, 10443,   445, 20443, 30443, 40443, 50443, 60443,   553,
1773      &   551, 10553,   555, 20553, 10551, 70553, 10555, 30553, 40553,
1774      & 50553, 60553,  2212,  2112, 12112, 12212,  1214,  2124, 22112,
1775      & 22212, 32112, 32212,  2116,  2216, 12116, 12216, 21214, 22124,
1776      & 42112, 42212, 31214, 32124,  1218,  2128,  1114,  2114,  2214/
1777       DATA (number(K),K=  172,  260) /
1778      &  2224, 31114, 32114, 32214, 32224,  1112,  1212,  2122,  2222,
1779      & 11114, 12114, 12214, 12224,  1116,  1216,  2126,  2226, 21112,
1780      & 21212, 22122, 22222, 21114, 22114, 22214, 22224, 11116, 11216,
1781      & 12126, 12226,  1118,  2118,  2218,  2228,  3122, 13122,  3124,
1782      & 23122, 33122, 13124, 43122, 53122,  3126, 13126, 23124,  3128,
1783      & 23126,  3222,  3212,  3112,  3224,  3214,  3114, 13112, 13212,
1784      & 13222, 13114, 13214, 13224, 23112, 23212, 23222,  3116,  3216,
1785      &  3226, 13116, 13216, 13226, 23114, 23214, 23224,  3118,  3218,
1786      &  3228,  3322,  3312,  3324,  3314, 13314, 13324,  3334,  4122,
1787      & 14122,  4222,  4212,  4112,  4232,  4132,  4332,  5122/
1788       DATA (name(K),K=    1,   76) /
1789      &'d           ','u           ','s           ','c           ',
1790      &'b           ','t           ','(dd)_1      ','(ud)_0      ',
1791      &'(ud)_1      ','(uu)_1      ','(sd)_0      ','(sd)_1      ',
1792      &'(su)_0      ','(su)_1      ','(ss)_1      ','(cd)_0      ',
1793      &'(cd)_1      ','(cu)_0      ','(cu)_1      ','(cs)_0      ',
1794      &'(cs)_1      ','(cc)_1      ','remnant 1   ','remnant 2   ',
1795      &'string      ','mod. string ','coll. string','reggeon     ',
1796      &'pomeron     ','gluon       ','gamma       ','W           ',
1797      &'Z           ','e           ','mu          ','tau         ',
1798      &'nu(e)       ','nu(mu)      ','nu(tau)     ','pi          ',
1799      &'pi          ','eta         ','rho(770)    ','rho(770)    ',
1800      &'ome(782)    ','etap(958)   ','f(0)(980)   ','a(0)(980)   ',
1801      &'a(0)(980)   ','phi(1020)   ','h(1)(1170)  ','b(1)(1235)  ',
1802      &'b(1)(1235)  ','a(1)(1260)  ','a(1)(1260)  ','f(2)(1270)  ',
1803      &'f(1)(1285)  ','eta(1295)   ','pi(1300)    ','pi(1300)    ',
1804      &'a(2)(1320)  ','a(2)(1320)  ','f(1)(1420)  ','ome(1420)   ',
1805      &'rho(1450)   ','rho(1450)   ','f(0)(1500)  ','f(2)p(1525) ',
1806      &'ome(1600)   ','ome(3)(1670)','pi(2)(1670) ','pi(2)(1670) ',
1807      &'phi(1680)   ','rho(3)(1690)','rho(3)(1690)','rho(1700)   '/
1808       DATA (name(K),K=   77,  152) /
1809      &'rho(1700)   ','f(J)(1710)  ','phi(3)(1850)','f(2)(2010)  ',
1810      &'f(4)(2050)  ','f(2)(2300)  ','f(2)(2340)  ','K           ',
1811      &'K           ','K(S)        ','K(L)        ','K*(892)     ',
1812      &'K*(892)     ','K(1)(1270)  ','K(1)(1270)  ','K(1)(1400)  ',
1813      &'K(1)(1400)  ','K*(1410)    ','K*(1410)    ','K(0)*(1430) ',
1814      &'K(0)*(1430) ','K(2)*(1430) ','K(2)*(1430) ','K*(1680)    ',
1815      &'K*(1680)    ','K(2)(1770)  ','K(2)(1770)  ','K(3)*(1780) ',
1816      &'K(3)*(1780) ','K(2)(1820)  ','K(2)(1820)  ','K(4)*(2045) ',
1817      &'K(4)*(2045) ','D           ','D           ','D*(2007)    ',
1818      &'D*(2010)    ','D(1)(2420)  ','D(2)*(2460) ','D(2)*(2460) ',
1819      &'D(s)        ','D(s)*       ','D(s1)(2536) ','B           ',
1820      &'B           ','B*          ','B*          ','B(s)        ',
1821      &'eta(c)(1S)  ','J/psi(1S)   ','chi(c0)(1P) ','chi(c1)(1P) ',
1822      &'chi(c2)(1P) ','psi(2S)     ','psi(3770)   ','psi(4040)   ',
1823      &'psi(4160)   ','psi(4415)   ','Ups(1S)     ','chi(b0)(1P) ',
1824      &'chi(b1)(1P) ','chi(b2)(1P) ','Ups(2S)     ','chi(b0)(2P) ',
1825      &'chi(b1)(2P) ','chi(b2)(2P) ','Ups(3S)     ','Ups(4S)     ',
1826      &'Ups(10860)  ','Ups(11020)  ','p           ','n           ',
1827      &'N(1440)     ','N(1440)     ','N(1520)     ','N(1520)     '/
1828       DATA (name(K),K=  153,  228) /
1829      &'N(1535)     ','N(1535)     ','N(1650)     ','N(1650)     ',
1830      &'N(1675)     ','N(1675)     ','N(1680)     ','N(1680)     ',
1831      &'N(1700)     ','N(1700)     ','N(1710)     ','N(1710)     ',
1832      &'N(1720)     ','N(1720)     ','N(2190)     ','N(2190)     ',
1833      &'Del(1232)   ','Del(1232)   ','Del(1232)   ','Del(1232)   ',
1834      &'Del(1600)   ','Del(1600)   ','Del(1600)   ','Del(1600)   ',
1835      &'Del(1620)   ','Del(1620)   ','Del(1620)   ','Del(1620)   ',
1836      &'Del(1700)   ','Del(1700)   ','Del(1700)   ','Del(1700)   ',
1837      &'Del(1905)   ','Del(1905)   ','Del(1905)   ','Del(1905)   ',
1838      &'Del(1910)   ','Del(1910)   ','Del(1910)   ','Del(1910)   ',
1839      &'Del(1920)   ','Del(1920)   ','Del(1920)   ','Del(1920)   ',
1840      &'Del(1930)   ','Del(1930)   ','Del(1930)   ','Del(1930)   ',
1841      &'Del(1950)   ','Del(1950)   ','Del(1950)   ','Del(1950)   ',
1842      &'Lambda      ','Lam(1405)   ','Lam(1520)   ','Lam(1600)   ',
1843      &'Lam(1670)   ','Lam(1690)   ','Lam(1800)   ','Lam(1810)   ',
1844      &'Lam(1820)   ','Lam(1830)   ','Lam(1890)   ','Lam(2100)   ',
1845      &'Lam(2110)   ','Sigma       ','Sigma       ','Sigma       ',
1846      &'Sig(1385)   ','Sig(1385)   ','Sig(1385)   ','Sig(1660)   ',
1847      &'Sig(1660)   ','Sig(1660)   ','Sig(1670)   ','Sig(1670)   '/
1848       DATA (name(K),K=  229,  260) /
1849      &'Sig(1670)   ','Sig(1750)   ','Sig(1750)   ','Sig(1750)   ',
1850      &'Sig(1775)   ','Sig(1775)   ','Sig(1775)   ','Sig(1915)   ',
1851      &'Sig(1915)   ','Sig(1915)   ','Sig(1940)   ','Sig(1940)   ',
1852      &'Sig(1940)   ','Sig(2030)   ','Sig(2030)   ','Sig(2030)   ',
1853      &'Xi          ','Xi          ','Xi(1530)    ','Xi(1530)    ',
1854      &'Xi(1820)    ','Xi(1820)    ','Omega       ','Lam(c)      ',
1855      &'Lam(c)(2593)','Sig(c)(2455)','Sig(c)(2455)','Sig(c)(2455)',
1856      &'Xi(c)       ','Xi(c)       ','Ome(c)      ','Lam(b)      '/
1857       DATA (ich3(K),K=    1,  260) /
1858      &-1, 2,-1, 2,-1, 2,-2, 1, 1, 4,-2,-2, 1, 1,-2, 1, 1, 4, 4, 1, 1, 4,
1859      & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,-3,-3, 0, 0, 0, 3, 0, 0, 0, 3,
1860      & 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 3, 0, 0, 0, 0, 3, 0, 3, 0, 0, 0, 3,
1861      & 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3,
1862      & 0, 0, 3, 0, 3, 0, 3, 0, 3, 3, 0, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 3,
1863      & 0, 0, 3, 0, 0, 3, 3, 3, 3, 3, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1864      & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 3,
1865      & 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3,-3, 0, 3, 6,-3, 0, 3, 6,
1866      &-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0,
1867      & 3, 6,-3, 0, 3, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,
1868      & 3, 0,-3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3,
1869      & 0, 3, 0,-3, 0,-3,-3, 0,-3, 3, 3, 6, 3, 0, 3, 0, 0, 0/
1870       DATA (iba3(K),K=    1,  260) /
1871      &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,
1872      &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1873      &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1874      &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1875      &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,
1876      &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,
1877      &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,
1878      &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/
1879       DATA (iq_linear(K),K=    1,  418) /
1880      & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 2,
1881      & 1, 0, 2, 1, 0, 2, 2, 0, 3, 1, 0, 3, 1, 0, 3, 2, 0, 3, 2, 0, 3, 3,
1882      & 0, 4, 1, 0, 4, 1, 0, 4, 2, 0, 4, 2, 0, 4, 3, 0, 4, 3, 0, 4, 4, 0,
1883      & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1884      & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1885      & 0, 0, 0, 0, 0, 0, 0, 2,-1, 0, 1,-1, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
1886      & 2,-2, 0, 3,-3, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 2,-2, 0, 1,
1887      &-1, 0, 2,-1, 0, 1,-1, 0, 2, 1, 0, 2,-2, 0, 2,-2, 0, 2,-2, 0, 1,-1,
1888      & 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
1889      & 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 1,
1890      &-1, 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2,
1891      & 0, 2,-2, 0, 2,-2, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 3,-1, 0, 2,-3, 0,
1892      & 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,
1893      &-3, 0, 2,-3, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3,
1894      & 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 4,-1, 0,
1895      & 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-3, 0, 4,
1896      &-3, 0, 4,-3, 0, 2,-5, 0, 1,-5, 0, 1,-5, 0, 2,-5, 0, 3,-5, 0, 4,-4,
1897      & 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0,
1898      & 4,-4, 0, 4,-4, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5/
1899       DATA (iq_linear(K),K=  419,  780) /
1900      &-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 2, 2,
1901      & 1, 2, 1, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 2, 2, 1,
1902      & 2, 1, 1, 2, 2, 1, 2, 2, 2, 2, 2, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2,
1903      & 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1,
1904      & 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2,
1905      & 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2,
1906      & 2, 2, 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, 1,
1907      & 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 1, 1, 2, 2, 2, 1, 1, 1, 1, 2, 1,
1908      & 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 3, 1, 2, 3,
1909      & 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1,
1910      & 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 2, 2, 3, 2, 1, 3, 1, 1, 3,
1911      & 3, 2, 2, 3, 2, 1, 3, 1, 1, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3,
1912      & 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2,
1913      & 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1,
1914      & 3, 2, 1, 3, 2, 2, 2, 3, 3, 1, 3, 3, 2, 3, 3, 1, 3, 3, 3, 3, 1, 3,
1915      & 3, 2, 3, 3, 3, 2, 1, 4, 4, 1, 2, 2, 2, 4, 2, 1, 2, 1, 1, 4, 3, 2,
1916      & 2, 3, 1, 2, 3, 3, 4, 5, 1, 2/
1917       DATA (xmass(K),K=    1,  114) /
1918      &3.0000E-01,3.0000E-01,3.5000E-01,1.4500E+00,4.5000E+00,1.7400E+02,
1919      &7.7133E-01,5.7933E-01,7.7133E-01,7.7133E-01,8.0473E-01,9.2953E-01,
1920      &8.0473E-01,9.2953E-01,1.0936E+00,1.9691E+00,2.0081E+00,1.9691E+00,
1921      &2.0081E+00,2.1543E+00,2.1797E+00,3.2753E+00,0.0000E+00,0.0000E+00,
1922      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1923      &0.0000E+00,8.0410E+01,9.1187E+01,5.1100E-04,1.0566E-01,1.7771E+00,
1924      &0.0000E+00,0.0000E+00,0.0000E+00,1.3957E-01,1.3498E-01,5.4730E-01,
1925      &7.7000E-01,7.7000E-01,7.8194E-01,9.5778E-01,9.8000E-01,9.8340E-01,
1926      &9.8340E-01,1.0194E+00,1.1700E+00,1.2295E+00,1.2295E+00,1.2300E+00,
1927      &1.2300E+00,1.2750E+00,1.2819E+00,1.2970E+00,1.3000E+00,1.3000E+00,
1928      &1.3181E+00,1.3181E+00,1.4262E+00,1.4190E+00,1.4650E+00,1.4650E+00,
1929      &1.5000E+00,1.5250E+00,1.6490E+00,1.6670E+00,1.6700E+00,1.6700E+00,
1930      &1.6800E+00,1.6910E+00,1.6910E+00,1.7000E+00,1.7000E+00,1.7120E+00,
1931      &1.8540E+00,2.0100E+00,2.0440E+00,2.2970E+00,2.3400E+00,4.9368E-01,
1932      &4.9767E-01,4.9767E-01,4.9767E-01,8.9166E-01,8.9610E-01,1.2720E+00,
1933      &1.2720E+00,1.4020E+00,1.4020E+00,1.4140E+00,1.4140E+00,1.4290E+00,
1934      &1.4290E+00,1.4256E+00,1.4324E+00,1.7170E+00,1.7170E+00,1.7730E+00,
1935      &1.7730E+00,1.7760E+00,1.7760E+00,1.8160E+00,1.8160E+00,2.0450E+00,
1936      &2.0450E+00,1.8693E+00,1.8646E+00,2.0067E+00,2.0100E+00,2.4222E+00/
1937       DATA (xmass(K),K=  115,  228) /
1938      &2.4589E+00,2.4590E+00,1.9685E+00,2.1124E+00,2.5353E+00,5.2789E+00,
1939      &5.2792E+00,5.3249E+00,5.3249E+00,5.3693E+00,2.9798E+00,3.0969E+00,
1940      &3.4173E+00,3.5105E+00,3.5562E+00,3.6860E+00,3.7699E+00,4.0400E+00,
1941      &4.1590E+00,4.4150E+00,9.4604E+00,9.8598E+00,9.8919E+00,9.9132E+00,
1942      &1.0023E+01,1.0232E+01,1.0255E+01,1.0268E+01,1.0355E+01,1.0580E+01,
1943      &1.0865E+01,1.1019E+01,9.3827E-01,9.3957E-01,1.4400E+00,1.4400E+00,
1944      &1.5200E+00,1.5200E+00,1.5350E+00,1.5350E+00,1.6500E+00,1.6500E+00,
1945      &1.6750E+00,1.6750E+00,1.6800E+00,1.6800E+00,1.7000E+00,1.7000E+00,
1946      &1.7100E+00,1.7100E+00,1.7200E+00,1.7200E+00,2.1900E+00,2.1900E+00,
1947      &1.2320E+00,1.2320E+00,1.2320E+00,1.2320E+00,1.6000E+00,1.6000E+00,
1948      &1.6000E+00,1.6000E+00,1.6200E+00,1.6200E+00,1.6200E+00,1.6200E+00,
1949      &1.7000E+00,1.7000E+00,1.7000E+00,1.7000E+00,1.9050E+00,1.9050E+00,
1950      &1.9050E+00,1.9050E+00,1.9100E+00,1.9100E+00,1.9100E+00,1.9100E+00,
1951      &1.9200E+00,1.9200E+00,1.9200E+00,1.9200E+00,1.9300E+00,1.9300E+00,
1952      &1.9300E+00,1.9300E+00,1.9500E+00,1.9500E+00,1.9500E+00,1.9500E+00,
1953      &1.1157E+00,1.4070E+00,1.5195E+00,1.6000E+00,1.6700E+00,1.6900E+00,
1954      &1.8000E+00,1.8100E+00,1.8200E+00,1.8300E+00,1.8900E+00,2.1000E+00,
1955      &2.1100E+00,1.1894E+00,1.1926E+00,1.1974E+00,1.3828E+00,1.3837E+00,
1956      &1.3872E+00,1.6600E+00,1.6600E+00,1.6600E+00,1.6700E+00,1.6700E+00/
1957       DATA (xmass(K),K=  229,  260) /
1958      &1.6700E+00,1.7500E+00,1.7500E+00,1.7500E+00,1.7750E+00,1.7750E+00,
1959      &1.7750E+00,1.9150E+00,1.9150E+00,1.9150E+00,1.9400E+00,1.9400E+00,
1960      &1.9400E+00,2.0300E+00,2.0300E+00,2.0300E+00,1.3149E+00,1.3213E+00,
1961      &1.5318E+00,1.5350E+00,1.8230E+00,1.8230E+00,1.6724E+00,2.2849E+00,
1962      &2.5939E+00,2.4528E+00,2.4536E+00,2.4522E+00,2.4656E+00,2.4703E+00,
1963      &2.7040E+00,5.6240E+00/
1964       DATA (gamma(K),K=    1,  114) /
1965      &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
1966      &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
1967      &8.0000E-01,8.0000E-01,8.0000E-01,0.0000E+00,0.0000E+00,0.0000E+00,
1968      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1969      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1970      &0.0000E+00,2.0600E+00,2.4900E+00,0.0000E+00,2.9959E-19,2.2700E-12,
1971      &0.0000E+00,0.0000E+00,0.0000E+00,2.5284E-17,7.8000E-09,1.1800E-06,
1972      &1.5070E-01,1.5070E-01,8.4100E-03,2.0300E-04,0.0000E+00,0.0000E+00,
1973      &0.0000E+00,4.4300E-03,3.6000E-01,1.4200E-01,1.4200E-01,0.0000E+00,
1974      &0.0000E+00,1.8550E-01,2.4000E-02,5.3000E-02,0.0000E+00,0.0000E+00,
1975      &1.0700E-01,1.0700E-01,5.5000E-02,1.7000E-01,3.1000E-01,3.1000E-01,
1976      &1.1200E-01,7.6000E-02,2.2000E-01,1.6800E-01,2.5800E-01,2.5800E-01,
1977      &1.5000E-01,1.6000E-01,1.6000E-01,2.4000E-01,2.4000E-01,1.3300E-01,
1978      &8.7000E-02,2.0000E-01,2.0800E-01,1.5000E-01,3.2000E-01,5.3140E-17,
1979      &0.0000E+00,7.3730E-15,1.2730E-17,5.0800E-02,5.0500E-02,9.0000E-02,
1980      &9.0000E-02,1.7400E-01,1.7400E-01,2.3200E-01,2.3200E-01,2.8700E-01,
1981      &2.8700E-01,9.8500E-02,1.0900E-01,3.2000E-01,3.2000E-01,1.8600E-01,
1982      &1.8600E-01,1.5900E-01,1.5900E-01,2.7600E-01,2.7600E-01,1.9800E-01,
1983      &1.9800E-01,6.2300E-13,1.5860E-12,5.0000E-03,2.0000E-03,1.8900E-02/
1984       DATA (gamma(K),K=  115,  228) /
1985      &2.3000E-02,2.5000E-02,1.4100E-12,2.0000E-03,0.0000E+00,3.9900E-13,
1986      &4.2200E-13,0.0000E+00,0.0000E+00,4.2700E-13,1.3200E-02,8.7000E-05,
1987      &1.4000E-02,8.8000E-04,2.0000E-03,2.7700E-04,2.3600E-02,5.2000E-02,
1988      &7.8000E-02,4.3000E-02,5.2500E-05,0.0000E+00,0.0000E+00,0.0000E+00,
1989      &4.4000E-05,0.0000E+00,0.0000E+00,0.0000E+00,2.6300E-05,1.0000E-02,
1990      &1.1000E-01,7.9000E-02,0.0000E+00,7.4240E-28,3.5000E-01,3.5000E-01,
1991      &1.2000E-01,1.2000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
1992      &1.5000E-01,1.5000E-01,1.3000E-01,1.3000E-01,1.0000E-01,1.0000E-01,
1993      &1.0000E-01,1.0000E-01,1.5000E-01,1.5000E-01,4.5000E-01,4.5000E-01,
1994      &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,3.5000E-01,3.5000E-01,
1995      &3.5000E-01,3.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
1996      &3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.5000E-01,3.5000E-01,
1997      &3.5000E-01,3.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,
1998      &2.0000E-01,2.0000E-01,2.0000E-01,2.0000E-01,3.5000E-01,3.5000E-01,
1999      &3.5000E-01,3.5000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,
2000      &2.5010E-15,5.0000E-02,1.5600E-02,1.5000E-01,3.5000E-02,6.0000E-02,
2001      &3.0000E-01,1.5000E-01,8.0000E-02,9.5000E-02,1.0000E-01,2.0000E-01,
2002      &2.0000E-01,8.2400E-15,8.9000E-06,4.4500E-15,3.5800E-02,3.6000E-02,
2003      &3.9400E-02,1.0000E-01,1.0000E-01,1.0000E-01,6.0000E-02,6.0000E-02/
2004       DATA (gamma(K),K=  229,  260) /
2005      &6.0000E-02,9.0000E-02,9.0000E-02,9.0000E-02,1.2000E-01,1.2000E-01,
2006      &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,2.2000E-01,2.2000E-01,
2007      &2.2000E-01,1.8000E-01,1.8000E-01,1.8000E-01,2.2700E-15,4.0200E-15,
2008      &9.1000E-03,9.9000E-03,2.4000E-02,2.4000E-02,8.0100E-15,3.1900E-12,
2009      &3.6000E-03,0.0000E+00,0.0000E+00,0.0000E+00,1.8600E-12,6.7000E-12,
2010      &1.0200E-11,5.3100E-13/
2011       DATA (idec_linear(K),K=    1,  304) /
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,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2014      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2015      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2016      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2017      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2018      &  0,  0,  0,  0,  0,  0,  3,  1,  1,  2,  2,  6,  0,  0,  0,  0,
2019      &  0,  0,  0,  0,  0,  3,  7,  7,  3,  8,  9,  1, 10, 14,  1, 15,
2020      & 16,  1, 17, 17,  1, 18, 20,  1, 21, 24,  0,  0,  0,  0,  0,  0,
2021      &  0,  0,  0,  1, 25, 29,  0,  0,  0,  0,  0,  0,  0,  0,  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,  0,  0,  0,  0,  0,  0,  0,  1, 30, 32,
2024      &  1, 33, 34,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1, 35, 37,  0,
2025      &  0,  0,  0,  0,  0,  0,  0,  0,  1, 38, 39,  0,  0,  0,  0,  0,
2026      &  0,  1, 40, 40,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2027      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  3, 41, 46,  0,  0,  0,  3,
2028      & 47, 48,  3, 49, 52,  1, 53, 54,  1, 55, 56,  1, 57, 58,  1, 59,
2029      & 60,  0,  0,  0,  0,  0,  0,  1, 61, 68,  1, 69, 76,  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=  305,  608) /
2032      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2033      &  0,  0,  0,  0,  0,  0,  0,  2, 77, 78,  2, 79, 82,  1, 83, 84,
2034      &  1, 85, 87,  0,  0,  0,  0,  0,  0,  0,  0,  0,  2, 88, 90,  1,
2035      & 91, 92,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2036      &  0,  0,  0,  0,  2, 93, 95,  1, 96, 98,  0,  0,  0,  0,  0,  0,
2037      &  0,  0,  0,  1, 99,101,  0,  0,  0,  0,  0,  0,  0,  0,  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,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2040      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  3,102,102,  1,103,112,  1,
2041      &113,122,  0,  0,  0,  0,  0,  0,  1,123,129,  1,130,136,  0,  0,
2042      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2043      &  0,  0,  0,  0,  0,  0,  1,137,144,  1,145,152,  0,  0,  0,  0,
2044      &  0,  0,  0,  0,  0,  0,  0,  0,  1,153,153,  1,154,155,  1,156,
2045      &157,  1,158,158,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2046      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,159,162,  1,
2047      &163,169,  1,170,176,  1,177,180,  0,  0,  0,  0,  0,  0,  0,  0,
2048      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2049      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2050      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0/
2051       DATA (idec_linear(K),K=  609,  780) /
2052      &  0,  0,  0,  0,  3,181,182,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2053      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2054      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  3,183,184,  3,185,
2055      &185,  3,186,186,  1,187,189,  1,190,192,  1,193,194,  0,  0,  0,
2056      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2057      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,195,203,  0,  0,
2058      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2059      &  0,  0,  0,  0,  0,  0,  1,204,216,  0,  0,  0,  3,217,217,  3,
2060      &218,218,  1,219,220,  1,221,222,  0,  0,  0,  0,  0,  0,  2,223,
2061      &225,  2,226,239,  0,  0,  0,  2,240,240,  2,241,241,  2,242,242,
2062      &  2,243,246,  2,247,251,  2,252,255,  0,  0,  0/
2063       DATA (isec_linear(K),K=    1,  152) /
2064      &     11,     12,    -12,     13,    -14,     16,     11,    -12,
2065      &     16,   -213,     16,      0,   -211,     16,      0,   -323,
2066      &     16,      0,    -13,     12,      0,     22,     22,      0,
2067      &     22,    -11,     11,     22,     22,      0,    111,     22,
2068      &     22,    111,    111,    111,    211,   -211,    111,    211,
2069      &   -211,     22,    211,   -211,      0,    111,    111,      0,
2070      &    211,    111,      0,    211,   -211,    111,    211,   -211,
2071      &      0,    111,     22,      0,    221,    211,   -211,    221,
2072      &    111,    111,    211,   -211,     22,     22,     22,      0,
2073      &    321,   -321,      0,    130,    310,      0,    113,    111,
2074      &      0,    211,   -211,    111,    221,     22,      0,    113,
2075      &    111,      0,   -213,    211,      0,    213,   -211,      0,
2076      &    211,   -211,      0,    111,    111,      0,    113,    111,
2077      &      0,   -213,    211,      0,    213,   -211,      0,    311,
2078      &   -313,      0,   -311,    313,      0,    113,    211,   -211,
2079      &    -13,     12,      0,    211,    111,      0,    211,    211,
2080      &   -211,    211,    111,    111,    -13,    111,     12,    -11,
2081      &    111,     12,    211,   -211,      0,    111,    111,      0,
2082      &    111,    111,    111,    211,   -211,    111,    211,     13/
2083       DATA (isec_linear(K),K=  153,  304) /
2084      &     12,    211,     11,     12,    321,    111,      0,    311,
2085      &    211,      0,    311,    111,      0,    321,   -211,      0,
2086      &    311,    111,      0,    321,   -211,      0,    321,    111,
2087      &      0,    311,    211,      0,    311,    111,      0,    321,
2088      &   -211,      0,    313,    111,      0,    323,   -211,      0,
2089      &    311,    113,      0,    321,   -213,      0,    311,    223,
2090      &      0,    311,    221,      0,    321,    111,      0,    311,
2091      &    211,      0,    323,    111,      0,    313,    211,      0,
2092      &    321,    113,      0,    311,    213,      0,    321,    223,
2093      &      0,    321,    221,      0,   -321,    211,    211,   -311,
2094      &    211,      0,   -321,    211,      0,   -321,    211,    111,
2095      &    311,    211,   -211,    311,    111,      0,    421,    111,
2096      &      0,    421,     22,      0,    421,    211,      0,    411,
2097      &    111,      0,    411,     22,      0,    221,    211,      0,
2098      &    321,   -321,    321,    321,   -311,      0,    431,     22,
2099      &      0,    431,     22,      0,    111,    111,      0,    211,
2100      &   -211,      0,     22,     22,      0,    -11,     11,      0,
2101      &    -13,     13,      0,    211,   -211,    111,    443,    211,
2102      &   -211,    443,    111,    111,    443,    221,      0,   2212/
2103       DATA (isec_linear(K),K=  305,  456) /
2104      &     11,     12,   2112,    111,      0,   2212,   -211,      0,
2105      &   2112,    111,    111,   2112,    211,   -211,   1114,    211,
2106      &      0,   2114,    111,      0,   2214,   -211,      0,   2112,
2107      &    113,      0,   2212,   -213,      0,   2112,    221,      0,
2108      &   2212,    111,      0,   2112,    211,      0,   2212,    111,
2109      &    111,   2212,    211,   -211,   2224,   -211,      0,   2214,
2110      &    111,      0,   2114,    211,      0,   2212,    113,      0,
2111      &   2112,    213,      0,   2212,    221,      0,   2212,   -211,
2112      &      0,   2112,    111,      0,   2214,   -211,      0,   2114,
2113      &    111,      0,   1114,    211,      0,   2212,   -213,      0,
2114      &   2112,    113,      0,   2212,    111,      0,   2112,    211,
2115      &      0,   2224,   -211,      0,   2214,    111,      0,   2114,
2116      &    211,      0,   2212,    113,      0,   2112,    213,      0,
2117      &   2212,   -211,      0,   2112,    111,      0,   2212,   -213,
2118      &      0,   2112,    113,      0,   3122,    311,      0,   3212,
2119      &    311,      0,   3112,    321,      0,   2112,    221,      0,
2120      &   2212,    111,      0,   2112,    211,      0,   2212,    113,
2121      &      0,   2112,    213,      0,   3122,    321,      0,   3222,
2122      &    311,      0,   3212,    321,      0,   2212,    221,      0/
2123       DATA (isec_linear(K),K=  457,  608) /
2124      &   2112,   -211,      0,   2212,   -211,      0,   2112,    111,
2125      &      0,   2212,    111,      0,   2112,    211,      0,   2212,
2126      &    211,      0,   2112,   -211,      0,   2114,   -211,      0,
2127      &   1114,    111,      0,   2112,   -213,      0,   2212,   -211,
2128      &      0,   2112,    111,      0,   2214,   -211,      0,   2114,
2129      &    111,      0,   1114,    211,      0,   2212,   -213,      0,
2130      &   2112,    113,      0,   2212,    111,      0,   2112,    211,
2131      &      0,   2224,   -211,      0,   2214,    111,      0,   2114,
2132      &    211,      0,   2212,    113,      0,   2112,    213,      0,
2133      &   2212,    211,      0,   2224,    111,      0,   2214,    211,
2134      &      0,   2212,    213,      0,   2212,   -211,      0,   2112,
2135      &    111,      0,   2212,    111,      0,   2112,    211,      0,
2136      &   3122,     22,      0,   2112,   -211,      0,   3122,    211,
2137      &      0,   3212,    211,      0,   3222,    111,      0,   3122,
2138      &    111,      0,   3222,   -211,      0,   3112,    211,      0,
2139      &   3122,   -211,      0,   3212,   -211,      0,   2112,   -311,
2140      &      0,   2212,   -321,      0,   3222,   -211,      0,   3212,
2141      &    111,      0,   3112,    211,      0,   3122,    221,      0,
2142      &   3224,   -211,      0,   3114,    211,      0,   3214,    111/
2143       DATA (isec_linear(K),K=  609,  760) /
2144      &      0,   2112,   -311,      0,   2212,   -321,      0,   3122,
2145      &    111,      0,   3122,    223,      0,   3122,    113,      0,
2146      &   3222,   -213,      0,   3112,    213,      0,   3212,    113,
2147      &      0,   3122,    221,      0,   3212,    221,      0,   3222,
2148      &   -211,      0,   3112,    211,      0,   3212,    111,      0,
2149      &   3122,    111,      0,   3122,   -211,      0,   3322,    111,
2150      &      0,   3312,    211,      0,   3322,   -211,      0,   3312,
2151      &    111,      0,   3322,   -211,      0,   3312,    111,      0,
2152      &   3122,   -321,      0,   3222,    221,      0,   3222,    331,
2153      &      0,   2212,   -311,      0,   3322,    321,      0,   3224,
2154      &    221,      0,   2214,    331,      0,   2224,   -321,      0,
2155      &   3122,    213,      0,   3212,    213,      0,   3222,    113,
2156      &      0,   3222,    223,      0,   2212,   -313,      0,   2214,
2157      &   -313,      0,   2224,   -323,      0,   4122,    211,      0,
2158      &   4122,    111,      0,   4122,   -211,      0,   3222,   -311,
2159      &      0,   3322,    211,      0,   3222,   -313,      0,   3322,
2160      &    213,      0,   3212,   -313,      0,   3222,   -323,      0,
2161      &   3322,    223,      0,   3312,    213,      0,   3214,   -313,
2162      &      0,   3322,   -311,      0,   3322,    313,      0,   3334/
2163       DATA (isec_linear(K),K=  761,  765) /
2164      &    213,      0,   3334,    211,      0/
2165       DATA (wg_chan(K),K=    1,  114) /
2166      &1.0000E+00,2.8000E-01,2.8000E-01,3.5000E-01,7.0000E-02,2.0000E-02,
2167      &1.0000E+00,9.9000E-01,1.0000E-02,3.8000E-01,3.0000E-02,3.0000E-01,
2168      &2.4000E-01,5.0000E-02,1.0000E+00,0.0000E+00,1.0000E+00,8.8800E-01,
2169      &2.5000E-02,8.7000E-02,4.8000E-01,2.4000E-01,2.6000E-01,2.0000E-02,
2170      &4.9100E-01,3.4400E-01,1.2900E-01,2.4000E-02,1.2000E-02,4.0000E-01,
2171      &3.0000E-01,3.0000E-01,6.0000E-01,4.0000E-01,4.0000E-01,3.0000E-01,
2172      &3.0000E-01,5.0000E-01,5.0000E-01,1.0000E+00,6.4000E-01,2.1000E-01,
2173      &6.0000E-02,2.0000E-02,3.0000E-02,4.0000E-02,6.9000E-01,3.1000E-01,
2174      &2.1000E-01,1.2000E-01,2.7000E-01,4.0000E-01,3.3000E-01,6.7000E-01,
2175      &3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,
2176      &1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,3.0000E-02,4.0000E-02,
2177      &5.0000E-02,2.0000E-02,1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,
2178      &3.0000E-02,4.0000E-02,5.0000E-02,2.0000E-02,7.0000E-01,3.0000E-01,
2179      &1.0000E-01,5.0000E-01,1.6000E-01,2.4000E-01,5.5000E-01,4.5000E-01,
2180      &6.8000E-01,3.0000E-01,2.0000E-02,3.0000E-01,4.0000E-01,3.0000E-01,
2181      &9.0000E-01,1.0000E-01,4.9000E-01,4.9000E-01,2.0000E-02,1.0000E-01,
2182      &1.0000E-01,8.0000E-01,6.0000E-01,3.0000E-01,1.0000E-01,1.0000E+00,
2183      &1.5000E-01,3.5000E-01,7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,
2184      &3.0000E-02,1.0000E-02,3.0000E-02,1.0000E-02,1.5000E-01,3.5000E-01/
2185       DATA (wg_chan(K),K=  115,  228) /
2186      &7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,3.0000E-02,1.0000E-02,
2187      &3.0000E-02,1.0000E-02,3.7000E-01,1.8000E-01,4.0000E-02,8.0000E-02,
2188      &1.3000E-01,1.3000E-01,7.0000E-02,1.8000E-01,3.7000E-01,1.3000E-01,
2189      &8.0000E-02,4.0000E-02,7.0000E-02,1.3000E-01,1.3000E-01,7.0000E-02,
2190      &4.7000E-01,2.3000E-01,5.0000E-02,1.0000E-02,2.0000E-02,2.0000E-02,
2191      &7.0000E-02,1.3000E-01,2.3000E-01,4.7000E-01,5.0000E-02,2.0000E-02,
2192      &1.0000E-02,2.0000E-02,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,
2193      &3.3000E-01,1.0000E+00,2.5000E-01,1.8000E-01,2.7000E-01,3.0000E-01,
2194      &8.0000E-02,1.7000E-01,2.4000E-01,3.0000E-02,1.8000E-01,1.0000E-01,
2195      &2.0000E-01,1.7000E-01,8.0000E-02,1.8000E-01,3.0000E-02,2.4000E-01,
2196      &2.0000E-01,1.0000E-01,2.5000E-01,2.7000E-01,1.8000E-01,3.0000E-01,
2197      &6.4000E-01,3.6000E-01,5.2000E-01,4.8000E-01,1.0000E+00,1.0000E+00,
2198      &8.8000E-01,6.0000E-02,6.0000E-02,8.8000E-01,6.0000E-02,6.0000E-02,
2199      &8.8000E-01,1.2000E-01,1.9000E-01,1.9000E-01,1.6000E-01,1.6000E-01,
2200      &1.7000E-01,3.0000E-02,3.0000E-02,3.0000E-02,4.0000E-02,1.0000E-01,
2201      &1.0000E-01,2.0000E-01,1.2000E-01,1.0000E-01,4.0000E-02,4.0000E-02,
2202      &5.0000E-02,7.5000E-02,7.5000E-02,3.0000E-02,3.0000E-02,4.0000E-02,
2203      &1.0000E+00,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,3.3000E-01,
2204      &2.5000E-01,2.5000E-01,5.0000E-01,2.0000E-02,3.0000E-02,7.0000E-02/
2205       DATA (wg_chan(K),K=  229,  255) /
2206      &2.0000E-02,2.0000E-02,4.0000E-02,1.3000E-01,7.0000E-02,6.0000E-02,
2207      &6.0000E-02,2.0000E-01,1.4000E-01,4.0000E-02,1.0000E-01,1.0000E+00,
2208      &1.0000E+00,1.0000E+00,2.5000E-01,3.0000E-02,3.0000E-01,4.2000E-01,
2209      &2.2000E-01,3.5000E-01,1.9000E-01,1.6000E-01,8.0000E-02,3.7000E-01,
2210      &2.0000E-01,3.6000E-01,7.0000E-02/
2211       DATA (id_psm_linear(K),K=    1,   36) /
2212      &    111,    211,   -311,    411,      0,      0,   -211,    111,
2213      &   -321,    421,      0,      0,    311,    321,    221,    431,
2214      &      0,      0,   -411,   -421,   -431,    441,      0,      0,
2215      &      0,      0,      0,      0,      0,      0,      0,      0,
2216      &      0,      0,      0,      0/
2217       DATA (id_vem_linear(K),K=    1,   36) /
2218      &    113,    213,   -313,    413,      0,      0,   -213,    113,
2219      &   -323,    423,      0,      0,    313,    323,    333,    433,
2220      &      0,      0,   -413,   -423,   -433,  20443,      0,      0,
2221      &      0,      0,      0,      0,      0,      0,      0,      0,
2222      &      0,      0,      0,      0/
2223       DATA (id_b8_linear(K),K=    1,  171) /
2224      &  1114,  2112,  3112,  4112,     0,     0,  2112,  2212,  3212,
2225      &  4122,     0,     0,  3112,  3212,  3312,  4132,     0,     0,
2226      &  4112,  4122,  4132,  4412,     0,     0,     0,     0,     0,
2227      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2228      &  2112,  2212,  3212,  4122,     0,     0,  2212,  2224,  3222,
2229      &  4222,     0,     0,  3212,  3222,  3322,  4232,     0,     0,
2230      &  4122,  4222,  4232,  4422,     0,     0,     0,     0,     0,
2231      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2232      &  3112,  3212,  3312,  4132,     0,     0,  3212,  3222,  3322,
2233      &  4232,     0,     0,  3312,  3322,  3334,  4332,     0,     0,
2234      &  4132,  4232,  4332,  4432,     0,     0,     0,     0,     0,
2235      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2236      &  4112,  4122,  4132,  4412,     0,     0,  4122,  4222,  4232,
2237      &  4422,     0,     0,  4132,  4232,  4332,  4432,     0,     0,
2238      &  4412,  4422,  4432,  4444,     0,     0,     0,     0,     0,
2239      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2240      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2241      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2242      &     0,     0,     0,     0,     0,     0,     0,     0,     0/
2243       DATA (id_b8_linear(K),K=  172,  216) /
2244      &     0,     0,     0,     0,     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=    1,  171) /
2250      &  1114,  2114,  3114,  4114,     0,     0,  2114,  2214,  3214,
2251      &  4214,     0,     0,  3114,  3214,  3314,  4314,     0,     0,
2252      &  4114,  4214,  4314,  4414,     0,     0,     0,     0,     0,
2253      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2254      &  2114,  2214,  3214,  4214,     0,     0,  2214,  2224,  3224,
2255      &  4224,     0,     0,  3214,  3224,  3324,  4324,     0,     0,
2256      &  4214,  4224,  4324,  4424,     0,     0,     0,     0,     0,
2257      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2258      &  3114,  3214,  3314,  4314,     0,     0,  3214,  3224,  3324,
2259      &  4324,     0,     0,  3314,  3324,  3334,  4334,     0,     0,
2260      &  4314,  4324,  4334,  4434,     0,     0,     0,     0,     0,
2261      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2262      &  4114,  4214,  4314,  4414,     0,     0,  4214,  4224,  4324,
2263      &  4424,     0,     0,  4314,  4324,  4334,  4434,     0,     0,
2264      &  4414,  4424,  4434,  4444,     0,     0,     0,     0,     0,
2265      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2266      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2267      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2268      &     0,     0,     0,     0,     0,     0,     0,     0,     0/
2269       DATA (id_b10_linear(K),K=  172,  216) /
2270      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2271      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2272      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2273      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2274      &     0,     0,     0,     0,     0,     0,     0,     0,     0/
2275
2276       ID_pdg_max = i_tab_max
2277
2278 C  copy from local to global variables
2279       do i=1,i_tab_max
2280         ID_pdg_list(i) = number(i)
2281         name_list(i)   = name(i)
2282         xm_list(i)     = xmass(i)
2283         gam_list(i)    = gamma(i)
2284         ich3_list(i)   = ich3(i)
2285         iba3_list(i)   = iba3(i)
2286         do j=1,3
2287           iq_list(j,i)   = iq_linear(3*(i-1)+j)
2288           idec_list(j,i) = idec_linear(3*(i-1)+j)
2289         enddo
2290       enddo
2291
2292 C  initialize hash table
2293       call pho_cpcini(ID_pdg_max,ID_pdg_list,ID_list)
2294
2295       itmp = IDEB(71)
2296       IDEB(71) = -1
2297
2298 C  quark index table for mesons
2299       do i=1,6
2300         do j=1,6
2301           id_psm_list(i,j) = ipho_pdg2id(id_psm_linear(6*(j-1)+i))
2302           id_vem_list(i,j) = ipho_pdg2id(id_vem_linear(6*(j-1)+i))
2303         enddo
2304       enddo
2305
2306 C  quark index table for baryons
2307       do i=1,6
2308         do j=1,6
2309           do k=1,6
2310             id_b8_list(i,j,k)  =
2311      &        ipho_pdg2id(id_b8_linear(36*(k-1)+6*(j-1)+i))
2312             id_b10_list(i,j,k) =
2313      &        ipho_pdg2id(id_b10_linear(36*(k-1)+6*(j-1)+i))
2314           enddo
2315         enddo
2316       enddo
2317
2318       IDEB(71) = itmp
2319
2320 C  copy secondary particles
2321 C  (translate PDG-ID to CPC and sort according to CPC)
2322       ichan = 0
2323       do i=1,i_tab_max
2324         if(idec_list(1,i).ne.0) then
2325           do j=idec_list(2,i),idec_list(3,i)
2326             ichan = ichan+1
2327             wg_sec_list(ichan) = wg_chan(j)
2328             do k=1,3
2329               if(isec_linear(3*(j-1)+k).ne.0) then
2330                 isec_list(k,ichan) = ipho_pdg2id(isec_linear(3*(j-1)+k))
2331               else
2332                 isec_list(k,ichan) = 0
2333               endif
2334             enddo
2335           enddo
2336         endif
2337       enddo
2338
2339 C  add two-pion background (low-mass photon dissociation)
2340       i = ipho_pdg2id(92)
2341       ichan = ichan+1
2342       idec_list(1,i) = 1
2343       idec_list(2,i) = ichan
2344       idec_list(3,i) = ichan
2345       wg_sec_list(ichan) = 1.D0
2346       isec_list(1,ichan) = ipho_pdg2id(211)
2347       isec_list(2,ichan) = ipho_pdg2id(-211)
2348       isec_list(3,ichan) = 0
2349
2350 C  min. mass limits for strings: q-qbar
2351       do i=1,6
2352         do j=1,6
2353           AM2P = 1000.D0
2354           AM2V = 1000.D0
2355           do k=1,3
2356 C  pseudo-scalar mesons
2357             i1 = iabs(id_psm_list(i,k))
2358             if(i1.ne.0) then
2359               AM1 = xm_list(i1)
2360             else
2361               AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2362             endif
2363             i2 = iabs(id_psm_list(k,j))
2364             if(i2.ne.0) then
2365               AM2 = xm_list(i2)
2366             else
2367               AM2 = pho_pmass(k,3)+pho_pmass(j,3)
2368             endif
2369             AM2P = MIN(AM2P,AM1+AM2)
2370 C  vector mesons
2371             i1 = iabs(id_vem_list(i,k))
2372             if(i1.ne.0) then
2373               AM1 = xm_list(i1)
2374             else
2375               AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2376             endif
2377             i2 = iabs(id_vem_list(k,j))
2378             if(i2.ne.0) then
2379               AM2 = xm_list(i2)
2380             else
2381               AM2 = pho_pmass(k,3)+pho_pmass(j,3)
2382             endif
2383             AM2V = MIN(AM2V,AM1+AM2)
2384           enddo
2385           xm_psm2_list(i,j) = AM2P
2386           xm_vem2_list(i,j) = AM2V
2387         enddo
2388       enddo
2389
2390 C  min. mass limits for strings: qq-q
2391       do i=1,6
2392         do j=1,6
2393           do k=1,6
2394             AM82  = 1000.D0
2395             AM102 = 1000.D0
2396             do l=1,3
2397 C  pseudo-scalar meson
2398               i1 = iabs(id_psm_list(k,l))
2399               if(i1.ne.0) then
2400                 AM1 = xm_list(i1)
2401               else
2402                 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2403               endif
2404 C  vector meson
2405               i2 = iabs(id_vem_list(k,l))
2406               if(i2.ne.0) then
2407                 AM2 = xm_list(i2)
2408               else
2409                 AM2 = pho_pmass(i,3)+pho_pmass(k,3)
2410               endif
2411 C  octet baryon
2412               AMM = min(AM1,AM2)
2413               K8  = id_b8_list(i,j,l)
2414               if(K8.ne.0) then
2415                 AM1 = xm_list(K8)
2416               else
2417                 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2418               endif
2419               AM82  = MIN(AM82, AM1 + AMM)
2420 C  decuplet baryon
2421               K10 = id_b10_list(i,j,l)
2422               if(K10.ne.0) then
2423                 AM2 = xm_list(K10)
2424               else
2425                 AM2 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2426               endif
2427               AM102 = MIN(AM102, AM2 + AMM)
2428             enddo
2429             xm_b82_list(i,j,k)  = AM82
2430             xm_b102_list(i,j,k) = AM102
2431           enddo
2432         enddo
2433       enddo
2434
2435 C  min. mass limits for strings: qq-qbarqbar
2436       do i=1,6
2437         do j=1,6
2438           do ii=1,6
2439             do jj=1,6
2440               AM82  = 1000.D0
2441               AM102 = 1000.D0
2442               do l=1,3
2443 C  octet baryons
2444                 K8  = id_b8_list(i,j,l)
2445                 if(K8.ne.0) then
2446                   AM1 = xm_list(K8)
2447                 else
2448                   AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2449                 endif
2450                 L8  = id_b8_list(ii,jj,l)
2451                 if(L8.ne.0) then
2452                   AM2 = xm_list(L8)
2453                 else
2454                   AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
2455                 endif
2456                 AM82  = MIN(AM82, AM1+AM2)
2457 C  decuplet baryons
2458                 K10 = id_b10_list(i,j,l)
2459                 if(K10.ne.0) then
2460                   AM1 = xm_list(K10)
2461                 else
2462                   AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2463                 endif
2464                 L10 = id_b10_list(ii,jj,l)
2465                 if(L10.ne.0) then
2466                   AM2 = xm_list(L10)
2467                 else
2468                   AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
2469                 endif
2470                 AM102 = MIN(AM102, AM1+AM2)
2471               enddo
2472               xm_bb82_list(i,j,ii,jj)  = AM82
2473               xm_bb102_list(i,j,ii,jj) = AM102
2474             enddo
2475           enddo
2476         enddo
2477       enddo
2478
2479       END
2480
2481 *$ CREATE PHO_PRESEL.FOR
2482 *COPY PHO_PRESEL
2483 CDECK  ID>, PHO_PRESEL
2484       SUBROUTINE PHO_PRESEL(MODE,IREJ)
2485 C**********************************************************************
2486 C
2487 C     user specific function to pre-select events during generation
2488 C
2489 C     input:   MODE  5  electron and photon kinematics
2490 C                   10  process and number of cut Pomerons
2491 C                   15  partons without construction of strings
2492 C                   20  partons assigned to strings
2493 C                   25  after fragmentation, complete final state
2494 C
2495 C     output:  IREJ  0  event accepted
2496 C                   50  event rejected
2497 C
2498 C**********************************************************************
2499       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2500       SAVE
2501
2502 C  input/output channels
2503       INTEGER LI,LO
2504       COMMON /POINOU/ LI,LO
2505 C  event debugging information
2506       INTEGER NMAXD
2507       PARAMETER (NMAXD=100)
2508       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2509      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2510       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2511      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2512
2513 C  standard particle data interface
2514       INTEGER NMXHEP
2515
2516       PARAMETER (NMXHEP=4000)
2517
2518       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
2519       DOUBLE PRECISION PHEP,VHEP
2520       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2521      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2522      &                VHEP(4,NMXHEP)
2523 C  extension to standard particle data interface (PHOJET specific)
2524       INTEGER IMPART,IPHIST,ICOLOR
2525       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
2526
2527 C  global event kinematics and particle IDs
2528       INTEGER IFPAP,IFPAB
2529       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2530       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2531 C  gamma-lepton or gamma-hadron vertex information
2532       INTEGER IGHEL,IDPSRC,IDBSRC
2533       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2534      &                 RADSRC,AMSRC,GAMSRC
2535       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2536      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2537      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2538 C  hard scattering data
2539       INTEGER MSCAHD
2540       PARAMETER ( MSCAHD = 50 )
2541       INTEGER LSCAHD,LSC1HD,LSIDX,
2542      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
2543       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
2544       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
2545      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
2546      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
2547      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
2548      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
2549      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
2550      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
2551 C  event weights and generated cross section
2552       INTEGER IPOWGC,ISWCUT,IVWGHT
2553       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2554       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2555      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2556
2557       IREJ = 0
2558
2559 *     XBJ = GQ2(2)/(GGECM**2+GQ2(2))
2560 *     IF(XBJ.LT.0.002D0) IREJ = 1
2561
2562       END
2563
2564 *$ CREATE PHO_FIXCOL.FOR
2565 *COPY PHO_FIXCOL
2566 CDECK  ID>, PHO_FIXCOL
2567       SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
2568 C**********************************************************************
2569 C
2570 C     interface to call PHOJET (fixed energy run) with
2571 C     collider kinematics
2572 C
2573 C     equivalen photon approximation to get photon flux
2574 C
2575 C     input:     NEV     number of events to generate
2576 C                THETA   azimuthal angle (micro radians)
2577 C                PHI     beam crossing angle
2578 C                        (with respect to x, in degrees)
2579 C                E1      energy of particle 1 (+z direction, GeV)
2580 C                E2      energy of particle 2 (-z direction, GeV)
2581 C
2582 C     note: particle types have to be specified before
2583 C           with PHO_SETPAR
2584 C
2585 C**********************************************************************
2586       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2587       SAVE
2588
2589       PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
2590
2591 C  input/output channels
2592       INTEGER LI,LO
2593       COMMON /POINOU/ LI,LO
2594 C  event debugging information
2595       INTEGER NMAXD
2596       PARAMETER (NMAXD=100)
2597       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2598      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2599       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2600      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2601 C  general process information
2602       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2603       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2604 C  global event kinematics and particle IDs
2605       INTEGER IFPAP,IFPAB
2606       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2607       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2608 C  model switches and parameters
2609       CHARACTER*8 MDLNA
2610       INTEGER ISWMDL,IPAMDL
2611       DOUBLE PRECISION PARMDL
2612       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2613 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
2614       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2615       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2616       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2617      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2618 C  integration precision for hard cross sections (obsolete)
2619       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2620       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2621 C  event weights and generated cross section
2622       INTEGER IPOWGC,ISWCUT,IVWGHT
2623       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2624       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2625      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2626
2627       DIMENSION P1(4),P2(4)
2628
2629 C  remnant initialization (only needed for DPMJET)
2630       ISAVP1 = IFPAP(1)
2631       ISAVB1 = IFPAB(1)
2632       IF(IFPAP(1).EQ.81) THEN
2633         IFPAP(1) = IDEQP(1)
2634         IFPAB(1) = IDEQB(1)
2635       ENDIF
2636       ISAVP2 = IFPAP(2)
2637       ISAVB2 = IFPAB(2)
2638       IF(IFPAP(2).EQ.82) THEN
2639         IFPAP(2) = IDEQP(2)
2640         IFPAB(2) = IDEQB(2)
2641       ENDIF
2642       PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
2643       PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
2644       PP1 = SQRT(E1**2-PMASS1**2)
2645       PP2 = SQRT(E2**2-PMASS2**2)
2646 C  beam crossing angle
2647       TH = 1.D-6*THETA/2.D0
2648       PH = PHI*BOG
2649       P1(1) = PP1*SIN(TH)*COS(PH)
2650       P1(2) = PP1*SIN(TH)*SIN(PH)
2651       P1(3) = PP1*COS(TH)
2652       P1(4) = E1
2653       P2(1) = PP2*SIN(TH)*COS(PH)
2654       P2(2) = PP2*SIN(TH)*SIN(PH)
2655       P2(3) = -PP2*COS(TH)
2656       P2(4) = E2
2657       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2658       IFPAP(1) = ISAVP1
2659       IFPAB(1) = ISAVB1
2660       IFPAP(2) = ISAVP2
2661       IFPAB(2) = ISAVB2
2662       ITRY = 0
2663       CALL PHO_PHIST(-1,SIGMAX)
2664       CALL PHO_LHIST(-1,SIGMAX)
2665 C  test of DPMJET interface (default is IPAMDL(13)=0)
2666       if(IPAMDL(13).gt.0) then
2667         MODE = IPAMDL(13)
2668         IPAMDL(13) = 0
2669       else
2670         MODE = 1
2671       endif
2672 C  main generation loop
2673       DO 50 I=1,NEV
2674  55     CONTINUE
2675         ITRY = ITRY+1
2676         CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
2677         IF(IREJ.NE.0) GOTO 55
2678         CALL PHO_PHIST(1,HSWGHT(0))
2679         CALL PHO_LHIST(1,HSWGHT(0))
2680  50   CONTINUE
2681
2682       IF(NEV.GT.0) THEN
2683         SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2684         WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2685      &  '=========================================================',
2686      &  ' *****   simulated cross section: ',SIGMAX,' mb  *****',
2687      &  '========================================================='
2688         CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2689         CALL PHO_PHIST(-2,SIGMAX)
2690         CALL PHO_LHIST(-2,SIGMAX)
2691       ELSE
2692         WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
2693       ENDIF
2694
2695       END
2696
2697 *$ CREATE PHO_FIXLAB.FOR
2698 *COPY PHO_FIXLAB
2699 CDECK  ID>, PHO_FIXLAB
2700       SUBROUTINE PHO_FIXLAB(PLAB,NEV)
2701 C**********************************************************************
2702 C
2703 C     interface to call PHOJET (fixed energy run) with
2704 C     LAB kinematics (second particle as target)
2705 C
2706 C     equivalent photon approximation to get photon flux
2707 C
2708 C     input:     NEV     number of events to generate
2709 C                PLAB    LAB momentum of particle 1
2710 C
2711 C     note: particle types have to be specified before
2712 C           with PHO_SETPAR
2713 C
2714 C**********************************************************************
2715       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2716       SAVE
2717
2718 C  input/output channels
2719       INTEGER LI,LO
2720       COMMON /POINOU/ LI,LO
2721 C  event debugging information
2722       INTEGER NMAXD
2723       PARAMETER (NMAXD=100)
2724       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2725      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2726       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2727      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2728 C  general process information
2729       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2730       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2731 C  global event kinematics and particle IDs
2732       INTEGER IFPAP,IFPAB
2733       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2734       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2735 C  model switches and parameters
2736       CHARACTER*8 MDLNA
2737       INTEGER ISWMDL,IPAMDL
2738       DOUBLE PRECISION PARMDL
2739       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2740 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
2741       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2742       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2743       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2744      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2745 C  integration precision for hard cross sections (obsolete)
2746       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2747       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2748 C  event weights and generated cross section
2749       INTEGER IPOWGC,ISWCUT,IVWGHT
2750       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2751       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2752      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2753
2754       DIMENSION P1(4),P2(4)
2755
2756 C  remnant initialization (only needed for DPMJET)
2757       SPCM = PLAB
2758       ISAVP1 = IFPAP(1)
2759       ISAVB1 = IFPAB(1)
2760       IF(IFPAP(1).EQ.81) THEN
2761         IFPAP(1) = IDEQP(1)
2762         IFPAB(1) = IDEQB(1)
2763       ENDIF
2764       ISAVP2 = IFPAP(2)
2765       ISAVB2 = IFPAB(2)
2766       IF(IFPAP(2).EQ.82) THEN
2767         IFPAP(2) = IDEQP(2)
2768         IFPAB(2) = IDEQB(2)
2769       ENDIF
2770 C  get momenta in LAB system
2771       PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
2772       PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
2773       IF(PMASS2.LT.0.1D0) THEN
2774         WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
2775      &    'no LAB system possible',IFPAB(1),IFPAB(2)
2776       ELSE
2777         P1(1) = 0.D0
2778         P1(2) = 0.D0
2779         P1(3) = PLAB
2780         P1(4) = SQRT(PMASS1+PLAB**2)
2781         P2(1) = 0.D0
2782         P2(2) = 0.D0
2783         P2(3) = 0.D0
2784         P2(4) = SQRT(PMASS2)
2785         CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2786         IFPAP(1) = ISAVP1
2787         IFPAB(1) = ISAVB1
2788         IFPAP(2) = ISAVP2
2789         IFPAB(2) = ISAVB2
2790         ITRY = 0
2791         CALL PHO_PHIST(-1,SIGMAX)
2792         CALL PHO_LHIST(-1,SIGMAX)
2793 C  event generation loop
2794         DO 40 I=1,NEV
2795  45       CONTINUE
2796           ITRY = ITRY+1
2797           CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
2798           IF(IREJ.NE.0) GOTO 45
2799           CALL PHO_LHIST(1,HSWGHT(0))
2800
2801           CALL PHO_PHIST(10,HSWGHT(0))
2802
2803  40     CONTINUE
2804         IF(NEV.GT.0) THEN
2805           SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2806           WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2807      &    '=========================================================',
2808      &    ' *****   simulated cross section: ',SIGMAX,' mb  *****',
2809      &    '========================================================='
2810           CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2811           CALL PHO_PHIST(-2,SIGMAX)
2812           CALL PHO_LHIST(-2,SIGMAX)
2813         ELSE
2814           WRITE(LO,'(1X,A,I5)')
2815      &      'PHO_FIXLAB: no events simulated',NEV
2816         ENDIF
2817       ENDIF
2818
2819       END
2820
2821 *$ CREATE PHO_GPHERA.FOR
2822 *COPY PHO_GPHERA
2823 CDECK  ID>, PHO_GPHERA
2824       SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
2825 C**********************************************************************
2826 C
2827 C     interface to call PHOJET (variable energy run) with
2828 C     HERA kinematics, photon as particle 2
2829 C
2830 C     equivalent photon approximation to get photon flux
2831 C
2832 C     input:     NEVENT  number of events to generate
2833 C                EE1     proton energy (LAB system)
2834 C                EE2     electron energy (LAB system)
2835 C             from /POFCUT/:
2836 C                YMIN2    lower limit of Y
2837 C                        (energy fraction taken by photon from electron)
2838 C                YMAX2    upper limit of Y
2839 C                Q2MIN2   lower limit of photon virtuality
2840 C                Q2MAX2   upper limit of photon virtuality
2841 C
2842 C**********************************************************************
2843       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2844       SAVE
2845
2846       PARAMETER ( DEPS = 1.D-10,
2847      &            PI   = 3.14159265359D0 )
2848
2849 C  input/output channels
2850       INTEGER LI,LO
2851       COMMON /POINOU/ LI,LO
2852 C  event debugging information
2853       INTEGER NMAXD
2854       PARAMETER (NMAXD=100)
2855       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2856      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2857       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2858      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2859 C  model switches and parameters
2860       CHARACTER*8 MDLNA
2861       INTEGER ISWMDL,IPAMDL
2862       DOUBLE PRECISION PARMDL
2863       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2864 C  photon flux kinematics and cuts
2865       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
2866      &                 YMIN1,YMAX1,YMIN2,YMAX2,
2867      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2868      &                 THMIN1,THMAX1,THMIN2,THMAX2
2869       INTEGER          ITAG1,ITAG2
2870       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
2871      &                YMIN1,YMAX1,YMIN2,YMAX2,
2872      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2873      &                THMIN1,THMAX1,THMIN2,THMAX2,
2874      &                ITAG1,ITAG2
2875 C  gamma-lepton or gamma-hadron vertex information
2876       INTEGER IGHEL,IDPSRC,IDBSRC
2877       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2878      &                 RADSRC,AMSRC,GAMSRC
2879       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2880      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2881      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2882 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
2883       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2884       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2885       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2886      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2887 C  event weights and generated cross section
2888       INTEGER IPOWGC,ISWCUT,IVWGHT
2889       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2890       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2891      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2892
2893       DIMENSION P1(4),P2(4)
2894
2895       WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
2896 C  assign particle momenta according to HERA kinematics
2897 C  proton data
2898       PROM = PHO_PMASS(2212,1)
2899       PROM2 = PROM**2
2900       IDPSRC(1) = 0
2901       IDBSRC(1) = 0
2902 C  electron data
2903       ELEM = 0.512D-03
2904       ELEM2 = ELEM**2
2905       AMSRC(2) = ELEM
2906       IDPSRC(2) = 11
2907       IDBSRC(2) = ipho_pdg2id(11)
2908 C
2909       Q2MIN = Q2MIN2
2910       Q2MAX = Q2MAX2
2911 C
2912       XIMAX = LOG(YMAX2)
2913       XIMIN = LOG(YMIN2)
2914       XIDEL = XIMAX-XIMIN
2915 C
2916       IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
2917      &  WRITE(LO,'(/1X,A,1P2E11.4)')
2918      &  'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
2919      &  Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
2920 C
2921       Max_tab = 50
2922       DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
2923       FLUXT = 0.D0
2924       FLUXL = 0.D0
2925       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
2926      &  'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
2927       DO 100 I=1,Max_tab
2928         Y = EXP(XIMIN+DELLY*DBLE(I-1))
2929         Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
2930         FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2931      &         -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
2932         FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
2933         FLUXT = FLUXT + Y*FFT
2934         FLUXL = FLUXL + Y*FFL
2935         IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
2936  100  CONTINUE
2937       FLUXT = FLUXT*DELLY
2938       FLUXL = FLUXL*DELLY
2939       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
2940      &  'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
2941 C
2942       AY = 0.D0
2943       AY2 = 0.D0
2944       YY = YMIN2
2945       Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2946       WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
2947      &        -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
2948       IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
2949 C
2950 C  initialization of PHOJET at upper energy limit
2951 C  proton momentum
2952       P1(1) = 0.D0
2953       P1(2) = 0.D0
2954       P1(3) = SQRT(EE1**2-PROM2+DEPS)
2955       P1(4) = EE1
2956 C  photon momentum
2957       EGAM = YMAX2*EE2
2958       P2(1) = 0.D0
2959       P2(2) = 0.D0
2960       P2(3) = -EGAM
2961       P2(4) = EGAM
2962 C  sum of both photon polarizations
2963       IGHEL(2) = -1
2964 C
2965       CALL PHO_SETPAR(1,2212,0,0.D0)
2966       CALL PHO_SETPAR(2,22,0,0.D0)
2967       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2968       CALL PHO_PHIST(-1,SIGMAX)
2969       CALL PHO_LHIST(-1,SIGMAX)
2970 C
2971 C  generation of events, flux calculation
2972
2973       ECMIN2 = ECMIN**2
2974       ECMAX2 = ECMAX**2
2975       AY = 0.D0
2976       AY2 = 0.D0
2977       Q22MIN = 1.D30
2978       Q22AVE = 0.D0
2979       Q22AV2 = 0.D0
2980       Q22MAX = 0.D0
2981       AN2MIN = 1.D30
2982       AN2MAX = 0.D0
2983       YY2MIN = 1.D30
2984       YY2MAX = 0.D0
2985       NITER = NEVENT
2986       ITRY = 0
2987       ITRW = 0
2988       DO 200 I=1,NITER
2989  150    CONTINUE
2990 C  sample y
2991         ITRY = ITRY+1
2992  175    CONTINUE
2993           ITRW = ITRW+1
2994           YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
2995           IF(ISWMDL(10).GE.2) THEN
2996             YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
2997           ELSE
2998             YEFF = 1.D0+(1.D0-YY)**2
2999           ENDIF
3000           Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
3001           Q2LOG = LOG(Q2MAX/Q2LOW)
3002           WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
3003           IF(WGMAX.LT.WGH) THEN
3004             WRITE(LO,'(1X,A,3E12.5)')
3005      &        'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
3006           ENDIF
3007         IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
3008 C  sample Q2
3009         IF(IPAMDL(174).EQ.1) THEN
3010  185      CONTINUE
3011             Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3012             WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
3013           IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
3014         ELSE
3015           Q2 = Q2LOW
3016         ENDIF
3017 C
3018
3019 C  incoming electron
3020         PINI(1,2) = 0.D0
3021         PINI(2,2) = 0.D0
3022         PINI(3,2) = -EE2
3023         PINI(4,2) = EE2
3024         PINI(5,2) = 0.D0
3025 C  outgoing electron
3026         YQ2 = SQRT((1.D0-YY)*Q2)
3027         Q2E = Q2/(4.D0*EE2)
3028         E1Y = EE2*(1.D0-YY)
3029         CALL PHO_SFECFE(SIF,COF)
3030         PFIN(1,2) = YQ2*COF
3031         PFIN(2,2) = YQ2*SIF
3032         PFIN(3,2) = -E1Y+Q2E
3033         PFIN(4,2) = E1Y+Q2E
3034         PFIN(5,2) = 0.D0
3035 C  set /POFSRC/
3036         GYY(2) = YY
3037         GQ2(2) = Q2
3038 C  polar angle
3039         PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3040 C  electron tagger
3041         IF(PFIN(4,2).GT.EEMIN2) THEN
3042           IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
3043         ENDIF
3044 C  azimuthal angle
3045         PFPHI(2) = ATAN2(COF,SIF)
3046 C  photon momentum
3047         P2(1) = -PFIN(1,2)
3048         P2(2) = -PFIN(2,2)
3049         P2(3) = PINI(3,2)-PFIN(3,2)
3050         P2(4) = PINI(4,2)-PFIN(4,2)
3051 C  proton momentum
3052         P1(1) = 0.D0
3053         P1(2) = 0.D0
3054         P1(3) = SQRT(EE1**2-PROM2)
3055         P1(4) = EE1
3056 C  ECMS cut
3057         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3058      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3059         IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
3060         GGECM = SQRT(GGECM)
3061 C
3062         PGAM(1,2) = P2(1)
3063         PGAM(2,2) = P2(2)
3064         PGAM(3,2) = P2(3)
3065         PGAM(4,2) = P2(4)
3066         PGAM(5,2) = -SQRT(Q2)
3067 C  photon helicity
3068         IF(ISWMDL(10).GE.2) THEN
3069           WGH  = YEFF-2.D0*ELEM2*YY**2/Q2
3070           WGHL = 2.D0*(1-YY)
3071           IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
3072             IGHEL(2) = 1
3073           ELSE
3074             IGHEL(2) = 0
3075           ENDIF
3076         ELSE
3077           IGHEL(2) = -1
3078         ENDIF
3079 C  user cuts
3080         CALL PHO_PRESEL(5,IREJ)
3081         IF(IREJ.NE.0) GOTO 175
3082 C  event generation
3083         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3084         IF(IREJ.NE.0) GOTO 150
3085
3086 C  statistics
3087         AY = AY+YY
3088         AY2 = AY2+YY*YY
3089         YY2MIN = MIN(YY2MIN,YY)
3090         YY2MAX = MAX(YY2MAX,YY)
3091         Q22MIN = MIN(Q22MIN,Q2)
3092         Q22MAX = MAX(Q22MAX,Q2)
3093         Q22AVE = Q22AVE+Q2
3094         Q22AV2 = Q22AV2+Q2*Q2
3095         AN2MIN = MIN(AN2MIN,PFTHE(2))
3096         AN2MAX = MAX(AN2MAX,PFTHE(2))
3097 C  histograms
3098         CALL PHO_PHIST(1,HSWGHT(0))
3099         CALL PHO_LHIST(1,HSWGHT(0))
3100  200  CONTINUE
3101 C
3102       WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
3103       WGY = WGY*LOG(YMAX2/YMIN2)
3104       AY  = AY/DBLE(NITER)
3105       AY2 = AY2/DBLE(NITER)
3106       DAY = SQRT((AY2-AY**2)/DBLE(NITER))
3107       Q22AVE = Q22AVE/DBLE(NITER)
3108       Q22AV2 = Q22AV2/DBLE(NITER)
3109       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3110       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
3111 C  output of histograms
3112       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3113      &'=========================================================',
3114      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
3115      &'========================================================='
3116       WRITE(LO,'(//1X,A,3I10)')
3117      &  'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
3118       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
3119      &  WGY,WEIGHT
3120       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY                 ',AY,DAY
3121       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON       ',
3122      &  YY2MIN,YY2MAX
3123       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2               ',
3124      &  Q22AVE,Q22AV2
3125       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON      ',
3126      &  Q22MIN,Q22MAX
3127       WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
3128      &  AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3129 C
3130       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3131       IF(NITER.GT.1) THEN
3132         CALL PHO_PHIST(-2,WEIGHT)
3133         CALL PHO_LHIST(-2,WEIGHT)
3134       ELSE
3135         WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
3136       ENDIF
3137
3138       END
3139
3140 *$ CREATE PHO_GGEPEM.FOR
3141 *COPY PHO_GGEPEM
3142 CDECK  ID>, PHO_GGEPEM
3143       SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
3144 C**********************************************************************
3145 C
3146 C     interface to call PHOJET (variable energy run) for
3147 C     gamma-gamma collisions on e+e- collider
3148 C
3149 C     fully differential equivalent (improved) photon approximation
3150 C     to get photon flux
3151 C
3152 C     input:     EE1     LAB system energy of electron/positron 1
3153 C                EE2     LAB system energy of electron/positron 2
3154 C                NEVENT  >0  number of events to generate
3155 C                        -1   initialization
3156 C                        -2   final call (cross section calculation)
3157 C            from /LEPCUT/:
3158 C                YMIN1   lower limit of Y1
3159 C                        (energy fraction taken by photon from electron)
3160 C                YMAX1   upper limit of Y1
3161 C                Q2MIN1  lower limit of photon virtuality
3162 C                Q2MAX1  upper limit of photon virtuality
3163 C                THMIN1  lower limit of scattered electron
3164 C                THMAX1  upper limit of scattered electron
3165 C                YMIN2   lower limit of Y2
3166 C                        (energy fraction taken by photon from electron)
3167 C                YMAX2   upper limit of Y2
3168 C                Q2MIN2  lower limit of photon virtuality
3169 C                Q2MAX2  upper limit of photon virtuality
3170 C                THMIN2  lower limit of scattered electron
3171 C                THMAX2  upper limit of scattered electron
3172 C
3173 C     output:    after final call with NEVENT=-2
3174 C                EE1     e+ e- cross section (mb)
3175 C                EE2     gamma-gamma cross section (mb)
3176 C
3177 C**********************************************************************
3178
3179       IMPLICIT NONE
3180
3181       SAVE
3182
3183       DOUBLE PRECISION EE1,EE2
3184       INTEGER NEVENT
3185
3186 C  input/output channels
3187       INTEGER LI,LO
3188       COMMON /POINOU/ LI,LO
3189 C  event debugging information
3190       INTEGER NMAXD
3191       PARAMETER (NMAXD=100)
3192       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3193      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3194       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3195      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3196 C  model switches and parameters
3197       CHARACTER*8 MDLNA
3198       INTEGER ISWMDL,IPAMDL
3199       DOUBLE PRECISION PARMDL
3200       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3201 C  some constants
3202       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3203       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3204      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3205 C  photon flux kinematics and cuts
3206       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
3207      &                 YMIN1,YMAX1,YMIN2,YMAX2,
3208      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3209      &                 THMIN1,THMAX1,THMIN2,THMAX2
3210       INTEGER          ITAG1,ITAG2
3211       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
3212      &                YMIN1,YMAX1,YMIN2,YMAX2,
3213      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3214      &                THMIN1,THMAX1,THMIN2,THMAX2,
3215      &                ITAG1,ITAG2
3216 C  gamma-lepton or gamma-hadron vertex information
3217       INTEGER IGHEL,IDPSRC,IDBSRC
3218       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3219      &                 RADSRC,AMSRC,GAMSRC
3220       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3221      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3222      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3223 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3224       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3225       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3226       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3227      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3228 C  event weights and generated cross section
3229       INTEGER IPOWGC,ISWCUT,IVWGHT
3230       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
3231       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
3232      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
3233
3234 C  external functions
3235       DOUBLE PRECISION DT_RNDM
3236
3237 C  local variables
3238       DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
3239      &  COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
3240      &  ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
3241      &  FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
3242      &  Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
3243      &  Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
3244      &  THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
3245      &  WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
3246      &  YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
3247
3248       INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
3249      &  ITRY_high,K,Max_tab,NITER,ITG1,ITG2
3250
3251       DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
3252       integer ipho_pdg2id
3253
3254 C  initialization of event generation
3255
3256       if(NEVENT.eq.-1) then
3257
3258         DO 10 I=1,4
3259           IHETRY(I) = 0
3260           IHEAC1(I) = 0
3261           IHEAC2(I) = 0
3262  10     CONTINUE
3263
3264         WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
3265
3266 C  electron data
3267         ELEM = 0.512D-03
3268         ELEM2 = ELEM**2
3269         AMSRC(1) = ELEM
3270         AMSRC(2) = ELEM
3271 C  lepton numbers
3272         IDPSRC(1) = 11
3273         IDPSRC(2) = -11
3274         IDBSRC(1) = ipho_pdg2id(11)
3275         IDBSRC(2) = ipho_pdg2id(-11)
3276
3277 C  check/update kinematic limitations
3278
3279         Ymi = min(Ymax1,1.D0-ELEM/EE1)
3280         if(Ymi.lt.Ymax1) then
3281           WRITE(LO,'(/1X,A,2E12.5)')
3282      &      'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
3283           Ymax1 = YMI
3284         endif
3285         Ymi = min(Ymax2,1.D0-ELEM/EE2)
3286         if(Ymi.lt.Ymax2) then
3287           WRITE(LO,'(/1X,A,2E12.5)')
3288      &      'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
3289           Ymax2 = YMI
3290         endif
3291
3292         YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
3293         IF(YMIN1.LT.YMI) THEN
3294           WRITE(LO,'(/1X,A,2E12.5)')
3295      &      'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
3296           YMIN1 = YMI
3297         ELSE IF(YMIN1.GT.YMI) THEN
3298           WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3299      &      'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
3300      &      '  INSTEAD OF',YMIN1
3301         ENDIF
3302         YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
3303         IF(YMIN2.LT.YMI) THEN
3304           WRITE(LO,'(/1X,A,2E12.5)')
3305      &      'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
3306           YMIN2 = YMI
3307         ELSE IF(YMIN2.GT.YMI) THEN
3308           WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3309      &      'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
3310      &      '  INSTEAD OF',YMIN2
3311         ENDIF
3312
3313 C  store COS of angular tagging range
3314         THMIC1 = COS(MAX(0.D0,THMIN1))
3315         THMAC1 = COS(MIN(THMAX1,PI))
3316         THMIC2 = COS(MAX(0.D0,THMIN2))
3317         THMAC2 = COS(MIN(THMAX2,PI))
3318
3319         X1MAX = LOG(YMAX1)
3320         X1MIN = LOG(YMIN1)
3321         X1DEL = X1MAX-X1MIN
3322         X2MAX = LOG(YMAX2)
3323         X2MIN = LOG(YMIN2)
3324         X2DEL = X2MAX-X2MIN
3325
3326 C  debug: integrated photon flux
3327
3328         if(IDEB(30).ge.1) then
3329           Max_tab = 50
3330           FLUXT = 0.D0
3331           FLUXL = 0.D0
3332           DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
3333           IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
3334      &      'table of photon flux (trans/long side 1)',Max_tab
3335           do I=1,Max_tab
3336             Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
3337             if((1.D0-Y1).gt.1.D-8) then
3338               Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
3339             else
3340               Q2low1 = 2.D0*Q2max1
3341             endif
3342             if(Q2low1.lt.Q2max1) then
3343               FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
3344      &        -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
3345               FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
3346             else
3347               FFT = 0.D0
3348               FFL = 0.D0
3349             endif
3350             FLUXT = FLUXT + Y1*FFL
3351             FLUXL = FLUXL + Y1*FFT
3352             IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
3353           enddo
3354           FLUXT = FLUXT*DELLY
3355           FLUXL = FLUXL*DELLY
3356           WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
3357      &      'integrated flux (trans/long side 1):',FLUXT,FLUXL
3358         endif
3359
3360 C  maximum weight
3361
3362         Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
3363         Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
3364         Y1 = YMIN1
3365         Y2 = YMIN2
3366         IF(ISWMDL(10).GE.2) THEN
3367 C  long. and transversely polarized photons
3368           WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
3369      &           -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3370      &           *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
3371      &           -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3372         ELSE
3373 C  transversely polarized photons only
3374           WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
3375      &           -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3376      &           *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
3377      &           -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3378         ENDIF
3379
3380 C  initialize gamma-gamma event generator
3381
3382 C  photon 1
3383         EGAM = YMAX1*EE1
3384         P1(1) = 0.D0
3385         P1(2) = 0.D0
3386         P1(3) = SQRT(EGAM**2-Q2LOW1)
3387         P1(4) = EGAM
3388 C  photon 2
3389         EGAM = YMAX2*EE2
3390         P2(1) = 0.D0
3391         P2(2) = 0.D0
3392         P2(3) = -SQRT(EGAM**2-Q2LOW2)
3393         P2(4) = EGAM
3394 C  sum of helicities
3395         IGHEL(1) = -1
3396         IGHEL(2) = -1
3397
3398 C  set min. energy for interpolation tables
3399         parmdl(19) = min(parmdl(19),ecmin)
3400
3401 C  initialize event gneration
3402         CALL PHO_SETPAR(1,22,0,0.D0)
3403         CALL PHO_SETPAR(2,22,0,0.D0)
3404         CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
3405         CALL PHO_PHIST(-1,SIGMAX)
3406         CALL PHO_LHIST(-1,SIGMAX)
3407
3408 C  generation of events, flux calculation
3409
3410         ECMIN2 = ECMIN**2
3411         ECMAX2 = ECMAX**2
3412         ECFRAC = ECMIN2/(4.D0*EE1*EE2)
3413         AY1  = 0.D0
3414         AY2  = 0.D0
3415         AYS1 = 0.D0
3416         AYS2 = 0.D0
3417         Q21MIN = 1.D30
3418         Q22MIN = 1.D30
3419         Q21MAX = 0.D0
3420         Q22MAX = 0.D0
3421         Q21AVE = 0.D0
3422         Q22AVE = 0.D0
3423         Q21AV2 = 0.D0
3424         Q22AV2 = 0.D0
3425         AN1MIN = 1.D30
3426         AN2MIN = 1.D30
3427         AN1MAX = 0.D0
3428         AN2MAX = 0.D0
3429         YY1MIN = 1.D30
3430         YY2MIN = 1.D30
3431         YY1MAX = 0.D0
3432         YY2MAX = 0.D0
3433         NITER = 0
3434         ITRY_low = 0
3435         ITRY_high = 0
3436         ITRW_low = 0
3437         ITRW_high = 0
3438
3439 C  generate NEVENT events (might be just 1 per call)
3440
3441       else if(NEVENT.gt.0) then
3442
3443         NITER = NITER+NEVENT
3444
3445         DO 200 I=1,NEVENT
3446
3447 C  sample y1, y2
3448  150      CONTINUE
3449           ITRY_low = ITRY_low+1
3450           if(ITRY_low.eq.1000000) then
3451             ITRY_low = 0
3452             ITRY_high = ITRY_high+1
3453           endif
3454
3455  175      CONTINUE
3456             ITRW_low = ITRW_low+1
3457             if(ITRW_low.eq.1000000) then
3458               ITRW_low = 0
3459               ITRW_high = ITRW_high+1
3460             endif
3461
3462             Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
3463             Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
3464             IF(Y1*Y2.LT.ECFRAC) GOTO 175
3465             IF(ISWMDL(10).GE.2) THEN
3466               YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
3467               YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
3468             ELSE
3469               YEFF1 = 1.D0+(1.D0-Y1)**2
3470               YEFF2 = 1.D0+(1.D0-Y2)**2
3471             ENDIF
3472
3473             Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
3474             Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
3475             Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
3476             Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
3477             WGH = (YEFF1*Q2LOG1
3478      &             -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3479      &           *(YEFF2*Q2LOG2
3480      &             -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3481             IF(WGMAX.LT.WGH) THEN
3482               WRITE(LO,'(1X,A,4E12.5)')
3483      &          'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
3484             ENDIF
3485           IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
3486
3487 C  limit on Ecm_gg (app. cut, precise cut applied later)
3488           GGECM2 = 4.D0*Y1*Y2*EE1*EE2
3489           if(GGECM2.lt.ECMIN2) goto 175
3490
3491 C  sample Q2
3492           IF(IPAMDL(174).EQ.1) THEN
3493  185        CONTINUE
3494               Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
3495               WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
3496             IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
3497           ELSE
3498             Q2P1 = Q2LOW1
3499           ENDIF
3500
3501           IF(IPAMDL(174).EQ.1) THEN
3502  186        CONTINUE
3503               Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
3504               WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
3505             IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
3506           ELSE
3507             Q2P2 = Q2LOW2
3508           ENDIF
3509
3510           GYY(1) = Y1
3511           GQ2(1) = Q2P1
3512           GYY(2) = Y2
3513           GQ2(2) = Q2P2
3514
3515 C  incoming electron 1
3516           PINI(1,1) = 0.D0
3517           PINI(2,1) = 0.D0
3518           PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
3519           PINI(4,1) = EE1
3520           PINI(5,1) = ELEM
3521 C  photon 1
3522           PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
3523           PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
3524      &         -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
3525           IF(PT2.LT.0.D0) GOTO 175
3526           PT = SQRT(PT2)
3527           CALL PHO_SFECFE(SIF1,COF1)
3528           P1(1) = COF1*PT
3529           P1(2) = SIF1*PT
3530           P1(3) = PP
3531           P1(4) = EE1*Y1
3532 C  outgoing electron 1
3533           PFIN(1,1) = -P1(1)
3534           PFIN(2,1) = -P1(2)
3535           PFIN(3,1) = PINI(3,1)-P1(3)
3536           PFIN(4,1) = PINI(4,1)-P1(4)
3537           PFIN(5,1) = ELEM
3538 C  incoming electron 2
3539           PINI(1,2) = 0.D0
3540           PINI(2,2) = 0.D0
3541           PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
3542           PINI(4,2) = EE2
3543           PINI(5,2) = 0.D0
3544 C  photon 2
3545           PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
3546           PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
3547      &         -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
3548           IF(PT2.LT.0.D0) GOTO 175
3549           PT = SQRT(PT2)
3550           CALL PHO_SFECFE(SIF2,COF2)
3551           P2(1) = COF2*PT
3552           P2(2) = SIF2*PT
3553           P2(3) = PP
3554           P2(4) = EE2*Y2
3555 C  outgoing electron 2
3556           PFIN(1,2) = -P2(1)
3557           PFIN(2,2) = -P2(2)
3558           PFIN(3,2) = PINI(3,2)-P2(3)
3559           PFIN(4,2) = PINI(4,2)-P2(4)
3560           PFIN(5,2) = ELEM
3561
3562 C  precise ECMS cut
3563
3564           GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3565      &           -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3566           IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
3567           GGECM = SQRT(GGECM2)
3568
3569 C  beam lepton detector acceptance
3570
3571 C  lepton tagger 1
3572           CPFTHE = PFIN(3,1)/PFIN(4,1)
3573           ITG1 = 0
3574           IF(PFIN(4,1).GE.EEMIN1) THEN
3575             IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
3576           ENDIF
3577
3578 C  lepton tagger 2
3579           CPFTHE = PFIN(3,2)/PFIN(4,2)
3580           ITG2 = 0
3581           IF(PFIN(4,2).GE.EEMIN2) THEN
3582             IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
3583           ENDIF
3584
3585 C  beam lepton taggers
3586
3587 C  anti-tag
3588           IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
3589           IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
3590 C  tag
3591           IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
3592           IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
3593 C  single-tag inclusive
3594           IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
3595      &      GOTO 175
3596 C  single-tag/anti-tag
3597           IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
3598      &      GOTO 175
3599
3600           PGAM(1,1) = P1(1)
3601           PGAM(2,1) = P1(2)
3602           PGAM(3,1) = P1(3)
3603           PGAM(4,1) = P1(4)
3604           PGAM(5,1) = -SQRT(Q2P1)
3605           PGAM(1,2) = P2(1)
3606           PGAM(2,2) = P2(2)
3607           PGAM(3,2) = P2(3)
3608           PGAM(4,2) = P2(4)
3609           PGAM(5,2) = -SQRT(Q2P2)
3610
3611 C  photon helicities
3612           IF(ISWMDL(10).GE.2) THEN
3613             WGH  = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
3614             WGHL = 2.D0*(1-Y1)
3615             IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
3616               IGHEL(1) = 1
3617             ELSE
3618               IGHEL(1) = 0
3619             ENDIF
3620             WGH  = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
3621             WGHL = 2.D0*(1-Y2)
3622             IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
3623               IGHEL(2) = 1
3624             ELSE
3625               IGHEL(2) = 0
3626             ENDIF
3627             K = 2*IGHEL(1)+IGHEL(2)+1
3628             IHETRY(K) = IHETRY(K)+1
3629           ELSE
3630             IGHEL(1) = -1
3631             IGHEL(2) = -1
3632           ENDIF
3633
3634 C  user cuts
3635           CALL PHO_PRESEL(5,IREJ)
3636           IF(IREJ.NE.0) GOTO 175
3637
3638           WGFX = 1.D0
3639 C  reweight according to LO photon emission diagrams (Budnev et al.)
3640           IF(IPAMDL(116).GE.1) THEN
3641             CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
3642             WGFX = FLXQPM/FLXAPP
3643             if(WGFX.gt.1.D0) then
3644               WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
3645      &          ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
3646      &          Y1,Y2,Q2P1,Q2P2,GGECM
3647             endif
3648           ENDIF
3649
3650 C  event generation
3651 *         IVWGHT(1) = 1
3652 *         EVWGHT(1) = MAX(WGFX,1.D0)
3653           CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3654           IF(IREJ.NE.0) GOTO 150
3655           IF(ISWMDL(10).GE.2) THEN
3656             K = 2*IGHEL(1)+IGHEL(2)+1
3657             IHEAC1(K) = IHEAC1(K)+1
3658           ENDIF
3659
3660 C  reweight according to QPM model (e+e- collider only)
3661           IF((KHDIR.GT.0).AND.
3662      &      (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
3663             CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
3664             WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
3665             IF(DT_RNDM(WG).GT.WG) GOTO 150
3666           ELSE IF(IPAMDL(116).GE.1) THEN
3667             IF(DT_RNDM(WG).GT.WGFX) GOTO 150
3668           ENDIF
3669
3670 C  polar angle
3671           PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
3672           PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3673 C  azimuthal angle
3674           PFPHI(1) = ATAN2(COF1,SIF1)
3675           PFPHI(2) = ATAN2(COF2,SIF2)
3676
3677 C  statistics
3678           AY1  = AY1+Y1
3679           AYS1 = AYS1+Y1*Y1
3680           AY2  = AY2+Y2
3681           AYS2 = AYS2+Y2*Y2
3682           Q21MIN = MIN(Q21MIN,Q2P1)
3683           Q22MIN = MIN(Q22MIN,Q2P2)
3684           Q21MAX = MAX(Q21MAX,Q2P1)
3685           Q22MAX = MAX(Q22MAX,Q2P2)
3686           AN1MIN = MIN(AN1MIN,PFTHE(1))
3687           AN2MIN = MIN(AN2MIN,PFTHE(2))
3688           AN1MAX = MAX(AN1MAX,PFTHE(1))
3689           AN2MAX = MAX(AN2MAX,PFTHE(2))
3690           YY1MIN = MIN(YY1MIN,Y1)
3691           YY2MIN = MIN(YY2MIN,Y2)
3692           YY1MAX = MAX(YY1MAX,Y1)
3693           YY2MAX = MAX(YY2MAX,Y2)
3694           Q21AVE = Q21AVE+Q2P1
3695           Q22AVE = Q22AVE+Q2P2
3696           Q21AV2 = Q21AV2+Q2P1*Q2P1
3697           Q22AV2 = Q22AV2+Q2P2*Q2P2
3698           IF(ISWMDL(10).GE.2) THEN
3699             K = 2*IGHEL(1)+IGHEL(2)+1
3700             IHEAC2(K) = IHEAC2(K)+1
3701           ENDIF
3702
3703 C  external histograms
3704           CALL PHO_PHIST(1,HSWGHT(0))
3705           CALL PHO_LHIST(1,HSWGHT(0))
3706  200    CONTINUE
3707
3708 C  final cross section calculation and event generation summary
3709
3710       else if(NEVENT.eq.-2) then
3711
3712 *       EVWGHT(1) = 1.D0
3713 *       IVWGHT(1) = 0
3714         DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
3715         DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
3716         WGY  = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
3717         WGY  = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
3718         AY1  = AY1/DBLE(NITER)
3719         AYS1 = AYS1/DBLE(NITER)
3720         DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
3721         AY2  = AY2/DBLE(NITER)
3722         AYS2 = AYS2/DBLE(NITER)
3723         DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
3724         Q21AVE = Q21AVE/DBLE(NITER)
3725         Q21AV2 = Q21AV2/DBLE(NITER)
3726         Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
3727         Q22AVE = Q22AVE/DBLE(NITER)
3728         Q22AV2 = Q22AV2/DBLE(NITER)
3729         Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3730         WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
3731         EE1 = WEIGHT
3732         EE2 = SIGMAX*DBLE(NITER)/DITRY
3733
3734 C  output of statistics, histograms
3735         WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3736      &    '=========================================================',
3737      &    ' *****   simulated cross section: ',WEIGHT,' mb  *****',
3738      &    '========================================================='
3739         WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
3740      &    'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
3741         WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
3742      &    WGY,WEIGHT
3743         WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1               ',
3744      &    AY1,DAY1
3745         WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2               ',
3746      &    AY2,DAY2
3747         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1     ',
3748      &    YY1MIN,YY1MAX
3749         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2     ',
3750      &    YY2MIN,YY2MAX
3751         WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1      ',
3752      &    Q21AVE,Q21AV2
3753         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1    ',
3754      &    Q21MIN,Q21MAX
3755         WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2  photon 2     ',
3756      &    Q22AVE,Q22AV2
3757         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2    ',
3758      &    Q22MIN,Q22MAX
3759         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
3760      &    AN1MIN,AN1MAX
3761         WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
3762      &    AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3763
3764         IF(ISWMDL(10).GE.2) THEN
3765           WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
3766      &    'Helicity decomposition:    0 0      0 1      1 0       1 1',
3767      &    'tried:        ',IHETRY,
3768      &    'accepted (1): ',IHEAC1,
3769      &    'accepted (2): ',IHEAC2
3770         ENDIF
3771
3772         CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3773         IF(NITER.GT.1) THEN
3774           CALL PHO_PHIST(-2,WEIGHT)
3775           CALL PHO_LHIST(-2,WEIGHT)
3776         ELSE
3777           WRITE(LO,'(1X,A,I4)')
3778      &      'PHO_GGEPEM: no output of histograms',NITER
3779         ENDIF
3780
3781       endif
3782
3783       END
3784
3785 *$ CREATE PHO_WGEPEM.FOR
3786 *COPY PHO_WGEPEM
3787 CDECK  ID>, PHO_WGEPEM
3788       SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
3789 C**********************************************************************
3790 C
3791 C     calculate cross section weights for
3792 C      fully differential equivalent (improved) photon approximation
3793 C     and/or
3794 C      fully differential QPM model with exact one-photon exchange graphs
3795 C
3796 C     (unpolarized lepton beams)
3797 C
3798 C     input:     IMODE     0   flux calculation only
3799 C                          1   flux folded with QPM cross section
3800 C                /POFSRC/  photon and electron momenta
3801 C                /POPRCS/  process type
3802 C                /POCKIN/  kinematics of hard scattering
3803 C
3804 C     output:    WGHAPP  weight of event according to approximation
3805 C                WGHQPM  weight of event according to one-photon exchange
3806 C
3807 C**********************************************************************
3808
3809       IMPLICIT NONE
3810
3811       SAVE
3812
3813       DOUBLE PRECISION WGHAPP,WGHQPM
3814       INTEGER IMODE
3815
3816 C  input/output channels
3817       INTEGER LI,LO
3818       COMMON /POINOU/ LI,LO
3819 C  event debugging information
3820       INTEGER NMAXD
3821       PARAMETER (NMAXD=100)
3822       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3823      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3824       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3825      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3826 C  model switches and parameters
3827       CHARACTER*8 MDLNA
3828       INTEGER ISWMDL,IPAMDL
3829       DOUBLE PRECISION PARMDL
3830       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3831 C  some constants
3832       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3833       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3834      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3835 C  gamma-lepton or gamma-hadron vertex information
3836       INTEGER IGHEL,IDPSRC,IDBSRC
3837       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3838      &                 RADSRC,AMSRC,GAMSRC
3839       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3840      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3841      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3842 C  general process information
3843       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3844       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3845 C  data on most recent hard scattering
3846       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3847       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3848      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
3849      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
3850       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3851      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
3852      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
3853      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
3854      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3855 C  hard scattering parameters used for most recent hard interaction
3856       INTEGER NFbeta,NF
3857       DOUBLE PRECISION ALQCD2,BQCD
3858       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
3859 C  currently activated parton density parametrizations
3860       CHARACTER*8 PDFNAM
3861       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
3862       DOUBLE PRECISION PDFLAM,PDFQ2M
3863       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
3864      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
3865
3866 C  standard particle data interface
3867       INTEGER NMXHEP
3868
3869       PARAMETER (NMXHEP=4000)
3870
3871       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
3872       DOUBLE PRECISION PHEP,VHEP
3873       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
3874      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
3875      &                VHEP(4,NMXHEP)
3876 C  extension to standard particle data interface (PHOJET specific)
3877       INTEGER IMPART,IPHIST,ICOLOR
3878       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
3879
3880       DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
3881      &  P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
3882      &  RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
3883      &  SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
3884      &  TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
3885      &  XM2,XQ2,XTM1,XTM2,XTM3,YCAP
3886       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
3887
3888       INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
3889
3890       DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
3891       DIMENSION HELFLX(6),SIGQPM(6)
3892
3893       WGHAPP = 1.D0
3894       WGHQPM = 0.D0
3895
3896 C  strict pt cutoff after putting partons on mass shell,
3897 C  calculated in gamma-gamma CMS
3898       if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
3899         if(PTfin.lt.PTwant) then
3900           if(ipamdl(121).gt.1) return
3901           if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
3902         endif
3903       endif
3904
3905 C  cross section of sampled event (approximate treatment)
3906
3907 C  photon flux
3908       DO 50 K=1,2
3909         XM2(K) = AMSRC(K)**2
3910         IF(abs(IGHEL(K)).EQ.1) THEN
3911           WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
3912      &              -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
3913         ELSE
3914           WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
3915         ENDIF
3916  50   CONTINUE
3917
3918       W2 = GGECM*GGECM
3919       IDIR   = 0
3920       WGHQQ  = 1.D0
3921
3922 C  direct or single-resolved gam-gam interaction
3923       IF((IMODE.GE.1).AND.
3924      &   (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
3925         IDIR   = 1
3926         WGHQQ = 0.D0
3927 C  determine final state partons
3928         DO 100 I=3,NHEP
3929           IF(ISTHEP(I).EQ.25) GOTO 110
3930  100    CONTINUE
3931         WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
3932      &    'inconsistent process information (MSPR)',MSPR
3933         CALL PHO_ABORT
3934  110    CONTINUE
3935         IPOS = I
3936 C  final state flavors
3937         IPFL1 = ABS(IDHEP(IPOS+3))
3938         IPFL2 = ABS(IDHEP(IPOS+4))
3939         SH = X1*X2*W2
3940 C  calculate alpha-em
3941         ALPHA1 = pho_alphae(QQAL)
3942 C  calculate alpha-s
3943         IF(MSPR.LT.14) THEN
3944           ALPHA2 = PHO_ALPHAS(QQAL,3)
3945         ENDIF
3946 C  LO matrix element (8 pi s dsig/dt)
3947 *       QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
3948         QC2 = Q_ch2(IPFL2)
3949         IF(IPFL2.EQ.0) THEN
3950           WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
3951      &      'invalid hard process - flavor combination',
3952      &      'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
3953         ENDIF
3954         IF(MSPR.EQ.10) THEN
3955           WGHQQ  = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
3956      &            *8.D0*PI*SH
3957         ELSE IF(MSPR.EQ.11) THEN
3958           WGHQQ  = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3959      &            *8.D0*PI*SH
3960         ELSE IF(MSPR.EQ.12) THEN
3961           WGHQQ  = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
3962      &            *8.D0*PI*SH
3963         ELSE IF(MSPR.EQ.13) THEN
3964           WGHQQ  = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3965      &            *8.D0*PI*SH
3966         ELSE IF(MSPR.EQ.14) THEN
3967           WGHQQ  = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
3968      &            *8.D0*PI*SH
3969         ENDIF
3970       ENDIF
3971
3972 C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3973       WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
3974
3975 C  full leading-order QPM prediction (Budnev et al.)
3976
3977 C  full two-gamma flux
3978
3979       P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
3980      &      -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
3981       P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
3982      &      -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
3983       Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
3984      &      -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
3985       P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
3986      &      -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
3987       DO 120 I=1,4
3988         P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
3989         P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
3990  120  CONTINUE
3991       XTM1 = 2.D0*P1Q2-Q1Q2
3992       XTM2 = 2.D0*P2Q1-Q1Q2
3993       XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
3994       XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
3995       YCAP = P1P2**2-XM2(1)*XM2(2)
3996       CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
3997
3998       RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
3999       RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
4000       RHO100 = XTM1**2/XCAP-1.D0
4001       RHO200 = XTM2**2/XCAP-1.D0
4002       RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
4003       RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
4004       SS     = 2.D0*P1P2+XM2(1)+XM2(2)
4005
4006       HELFLX(1) = 4.D0*RHO1PP*RHO2PP
4007       HELFLX(2) = RHOPM2
4008       HELFLX(3) = 2.D0*RHO1PP*RHO200
4009       HELFLX(4) = 2.D0*RHO100*RHO2PP
4010       HELFLX(5) = RHO100*RHO200
4011       HELFLX(6) = -RHOP08
4012
4013 C  only flux calculation
4014
4015       IF(IDIR.EQ.0) THEN
4016         IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4017           WEIGHT = HELFLX(1)
4018         ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4019           WEIGHT = HELFLX(3)
4020         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4021           WEIGHT = HELFLX(4)
4022         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4023           WEIGHT = HELFLX(5)
4024         ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
4025           WEIGHT = HELFLX(1)
4026         ELSE
4027           WRITE(LO,'(/1X,A,2I3)')
4028      &      'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4029           WRITE(LO,'(1X,A,I12)')
4030      &      'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4031           WEIGHT = 0.D0
4032         ENDIF
4033
4034 C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4035         WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4036      &          *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4037
4038       ELSE
4039
4040 C  flux folded with cross section
4041 C  polarized, leading order gam gam --> q qbar cross sections
4042
4043         DO 125 I=1,6
4044           SIGQPM(I) = 0.D0
4045  125    CONTINUE
4046 C  momenta of produced parton pair
4047         I1 = IPOS+3
4048         I2 = IPOS+4
4049         DO 150 K=1,4
4050           XK1(K) = PHEP(K,I1)
4051           XK2(K) = PHEP(K,I2)
4052  150    CONTINUE
4053         XQ2 = PHEP(5,I2)**2
4054
4055         IF(MSPR.EQ.14) THEN
4056 C  direct photon-photon interaction
4057           XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
4058      &          +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
4059      &          +(PGAM(3,1)-XK1(3))**2
4060           XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
4061      &          +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
4062      &          +(PGAM(3,1)-XK2(3))**2
4063           CC = Q1Q2
4064           AA = XKAP*XKAM-GQ2(1)*GQ2(2)
4065           BB = CC**2-XKAP*XKAM
4066           DD = CC**2-GQ2(1)*GQ2(2)
4067           RR = -XQ2+W2*AA/(4.D0*DD)
4068           Q1KK = Q1Q2-GQ2(1)
4069           Q2KK = Q1Q2-GQ2(2)
4070           FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
4071
4072         ELSE
4073 C  single-resolved photon-hadron interactions
4074 C  Mandelstam variables
4075           IF(MSPR.LE.11) THEN
4076             TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
4077      &          -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
4078             UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
4079      &          -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
4080           ELSE
4081             TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
4082      &          -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
4083             UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
4084      &          -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
4085           ENDIF
4086           V = TH/SH
4087           U = UH/SH
4088         ENDIF
4089
4090         WEIGHT = 0.D0
4091         IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4092           IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
4093             IF(MSPR.EQ.10) THEN
4094               Q2 = -GQ2(1)
4095               SP = SH-XQ2
4096               TP = UH-XQ2
4097             ELSE
4098               Q2 = -GQ2(2)
4099               SP = SH-XQ2
4100               TP = TH-XQ2
4101             ENDIF
4102             SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
4103      &        *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
4104      &        +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
4105      &       -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
4106      &        -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
4107      &        (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
4108      &        4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
4109      &        (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
4110             WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4111           ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
4112             IF(MSPR.EQ.11) THEN
4113               Q2 = -GQ2(1)
4114             ELSE
4115               Q2 = -GQ2(2)
4116             ENDIF
4117             SP = SH
4118             TP = UH
4119             SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
4120      &        *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
4121      &        - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
4122      &            (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
4123      &        (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
4124      &         4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
4125      &        +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
4126      &        *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
4127      &        SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
4128      &        (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
4129      &        *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
4130      &        +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
4131      &        *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
4132      &        2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
4133      &        (Q2-SP-TP+XQ2)**2)
4134             WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4135           ELSE IF(MSPR.EQ.14) THEN
4136             SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
4137             SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
4138             SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
4139      &              -2.D0*XKAP*XKAM*AA
4140             SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
4141             SIGQPM(2) = SWPPMM*FAC
4142             WEIGHT = HELFLX(1)*SIGQPM(1)
4143      &              +HELFLX(2)*SIGQPM(2)
4144           ENDIF
4145         ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4146           IF(MSPR.EQ.12) THEN
4147             Q2 = -GQ2(2)
4148             SP = SH-XQ2
4149             TP = TH-XQ2
4150             SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4151      &               *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4152      &               SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4153      &               TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4154      &               2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4155      &               2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4156      &               XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4157      &               (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4158             WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4159           ELSE IF(MSPR.EQ.13) THEN
4160             Q2 = -GQ2(2)
4161             SP = SH
4162             TP = TH
4163             SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4164      &        *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4165      &        SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4166             WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4167           ELSE IF(MSPR.EQ.14) THEN
4168             SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
4169      &              -XKAP*XKAM*Q1KK**2)/DD
4170             SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
4171             SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4172      &              *SQRT(GQ2(1)*GQ2(2))/DD
4173             SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4174      &              +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4175             SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4176      &              *SQRT(GQ2(1)*GQ2(2))/DD
4177             SIGQPM(3) = SWP0P0*FAC
4178             SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4179             WEIGHT = HELFLX(3)*SIGQPM(3)
4180      &              +HELFLX(6)*SIGQPM(6)/2.D0
4181           ENDIF
4182         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4183           IF(MSPR.EQ.10) THEN
4184             Q2 = -GQ2(1)
4185             SP = SH-XQ2
4186             TP = UH-XQ2
4187             SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4188      &               *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4189      &               SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4190      &               TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4191      &               2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4192      &               2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4193      &               XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4194      &               (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4195             WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
4196           ELSE IF(MSPR.EQ.11) THEN
4197             Q2 = -GQ2(1)
4198             SP = SH
4199             TP = TH
4200             SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4201      &        *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4202      &        SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4203             WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
4204           ELSE IF(MSPR.EQ.14) THEN
4205             SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
4206      &                               -XKAP*XKAM*Q2KK**2)/DD
4207             SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
4208             SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4209      &              *SQRT(GQ2(1)*GQ2(2))/DD
4210             SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4211      &              +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4212             SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4213      &              *SQRT(GQ2(1)*GQ2(2))/DD
4214             SIGQPM(4) = SW0P0P*FAC
4215             SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4216             WEIGHT = HELFLX(4)*SIGQPM(4)
4217      &              +HELFLX(6)*SIGQPM(6)/2.D0
4218           ENDIF
4219         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4220           IF(MSPR.EQ.14) THEN
4221             SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
4222             SIGQPM(5) = SW0000*FAC
4223             WEIGHT = HELFLX(5)*SIGQPM(5)
4224           ENDIF
4225         ELSE
4226           WRITE(LO,'(/1X,A,2I3)')
4227      &      'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4228           WRITE(LO,'(1X,A,I12)')
4229      &      'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4230           WEIGHT = 0.D0
4231         ENDIF
4232
4233 C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4234
4235         WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4236      &          *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4237
4238       ENDIF
4239
4240       END
4241
4242 *$ CREATE PHO_GGBLSR.FOR
4243 *COPY PHO_GGBLSR
4244 CDECK  ID>, PHO_GGBLSR
4245       SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
4246      &                      Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
4247 C***********************************************************************
4248 C
4249 C     interface to call PHOJET (variable energy run) for
4250 C     gamma-gamma collisions via laser backscattering
4251 C
4252 C     input:     EE1         lab. system energy of electron/positron 1
4253 C                EE2         lab. system energy of electron/positron 2
4254 C                NEVENT      number of events to generate
4255 C                Pl_lam_1/2  product of electron and photon pol.
4256 C                X_1/2       standard X parameter
4257 C                rho         ratio of distance to conversion point and
4258 C                            transverse beam size
4259 C                A           ellipticity of electon beam
4260 C
4261 C                (see Ginzburg & Kotkin hep-ph/9905462)
4262 C
4263 C            from /LEPCUT/:
4264 C                YMIN1   lower limit of Y1
4265 C                        (energy fraction taken by photon from electron)
4266 C                YMAX1   upper limit of Y1
4267 C                YMIN2   lower limit of Y2
4268 C                        (energy fraction taken by photon from electron)
4269 C                YMAX2   upper limit of Y2
4270 C
4271 C***********************************************************************
4272       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4273       SAVE
4274
4275       PARAMETER ( PI   = 3.14159265359D0 )
4276
4277 C  input/output channels
4278       INTEGER LI,LO
4279       COMMON /POINOU/ LI,LO
4280 C  event debugging information
4281       INTEGER NMAXD
4282       PARAMETER (NMAXD=100)
4283       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4284      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4285       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4286      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4287 C  photon flux kinematics and cuts
4288       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4289      &                 YMIN1,YMAX1,YMIN2,YMAX2,
4290      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4291      &                 THMIN1,THMAX1,THMIN2,THMAX2
4292       INTEGER          ITAG1,ITAG2
4293       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4294      &                YMIN1,YMAX1,YMIN2,YMAX2,
4295      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4296      &                THMIN1,THMAX1,THMIN2,THMAX2,
4297      &                ITAG1,ITAG2
4298 C  gamma-lepton or gamma-hadron vertex information
4299       INTEGER IGHEL,IDPSRC,IDBSRC
4300       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4301      &                 RADSRC,AMSRC,GAMSRC
4302       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4303      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4304      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4305 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
4306       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4307       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4308       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4309      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4310 C  event weights and generated cross section
4311       INTEGER IPOWGC,ISWCUT,IVWGHT
4312       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4313       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4314      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4315
4316       parameter (N_dim=100)
4317       dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
4318      &          X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
4319      &          Xgrid(96),Wgrid(96)
4320
4321       DIMENSION P1(4),P2(4)
4322
4323       Pi2 = 2.D0*Pi
4324
4325       WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
4326
4327       YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
4328       YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
4329       IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
4330         WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
4331      &    'invalid Ymin1,Ymin2',YMIN1,YMIN2
4332         RETURN
4333       ENDIF
4334       IDPSRC(1) = 0
4335       IDBSRC(1) = 0
4336       IDPSRC(2) = 0
4337       IDBSRC(2) = 0
4338
4339 C  initialize sampling
4340
4341       Max_tab = 50
4342       DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
4343       DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
4344
4345       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4346      &  'PHO_GGBLSR: table of photon flux ',Max_tab
4347
4348       DO 100 I=1,Max_tab
4349
4350         y1 = YMIN1+DELY1*DBLE(I-1)
4351         r1 = y1/(X_1*(1.D0-y1))
4352         X_inp_1(i) = y1
4353         F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
4354      &            -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
4355
4356         y2 = YMIN2+DELY2*DBLE(I-1)
4357         r2 = y2/(X_2*(1.D0-y2))
4358         X_inp_2(i) = y2
4359         F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
4360      &            -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
4361
4362         IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
4363      &    y1,F_inp_1(i),y2,F_inp_2(i)
4364
4365  100  CONTINUE
4366
4367       call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4368       call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4369
4370 C  initialize event generator
4371
4372 C  photon 1
4373       EGAM = YMAX1*EE1
4374       P1(1) = 0.D0
4375       P1(2) = 0.D0
4376       P1(3) = EGAM
4377       P1(4) = EGAM
4378 C  photon 2
4379       EGAM = YMAX2*EE2
4380       P2(1) = 0.D0
4381       P2(2) = 0.D0
4382       P2(3) = -EGAM
4383       P2(4) = EGAM
4384       CALL PHO_SETPAR(1,22,0,0.D0)
4385       CALL PHO_SETPAR(2,22,0,0.D0)
4386       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4387       CALL PHO_PHIST(-1,SIGMAX)
4388       CALL PHO_LHIST(-1,SIGMAX)
4389
4390 C  generation of events
4391
4392       AY1  = 0.D0
4393       AY2  = 0.D0
4394       AYS1 = 0.D0
4395       AYS2 = 0.D0
4396       NITER = NEVENT
4397       ITRY = 0
4398       ITRW = 0
4399       DO 200 I=1,NITER
4400  150    CONTINUE
4401         ITRY = ITRY+1
4402  175    CONTINUE
4403           ITRW = ITRW+1
4404
4405           call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4406           call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4407
4408           g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
4409           g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
4410           if(abs(1.D0-A).lt.1.D-3) then
4411             v = rho**2/4.D0*g_1*g_2
4412             Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
4413           else
4414             Nint = 16
4415             call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
4416             A2 = A**2
4417             fac = rho**2/(4.D0*(1.D0+A2))
4418             Wght = 0.D0
4419             do i1=1,Nint
4420               phi_1 = Xgrid(i1)
4421               do i2=1,Nint
4422                 phi_2 = Xgrid(i2)
4423                 Wght = Wght
4424      &            +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
4425      &                         +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
4426      &            *Wgrid(i1)*Wgrid(i2)
4427               enddo
4428             enddo
4429             Wght = Wght/Pi2**2
4430           endif
4431
4432           IF(Wght.GT.1.D0) THEN
4433             WRITE(LO,'(1X,A,5E11.4)')
4434      &        'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
4435           ENDIF
4436         IF(DT_RNDM(dum).GT.Wght) GOTO 175
4437
4438         Y1 = X_out_1
4439         Y2 = X_out_2
4440
4441         Q2P1 = 0.D0
4442         Q2P2 = 0.D0
4443         GYY(1) = Y1
4444         GQ2(1) = Q2P1
4445         GYY(2) = Y2
4446         GQ2(2) = Q2P2
4447 C  incoming electron 1
4448         PINI(1,1) = 0.D0
4449         PINI(2,1) = 0.D0
4450         PINI(3,1) = EE1
4451         PINI(4,1) = EE1
4452         PINI(5,1) = 0.D0
4453 C  outgoing electron 1
4454         YQ2 = SQRT((1.D0-Y1)*Q2P2)
4455         Q2E = Q2P1/(4.D0*EE1)
4456         E1Y = EE1*(1.D0-Y1)
4457         CALL PHO_SFECFE(SIF,COF)
4458         PFIN(1,1) = YQ2*COF
4459         PFIN(2,1) = YQ2*SIF
4460         PFIN(3,1) = E1Y-Q2E
4461         PFIN(4,1) = E1Y+Q2E
4462         PFIN(5,1) = 0.D0
4463 C  photon 1
4464         P1(1) = -PFIN(1,1)
4465         P1(2) = -PFIN(2,1)
4466         P1(3) = PINI(3,1)-PFIN(3,1)
4467         P1(4) = PINI(4,1)-PFIN(4,1)
4468 C  incoming electron 2
4469         PINI(1,2) = 0.D0
4470         PINI(2,2) = 0.D0
4471         PINI(3,2) = -EE2
4472         PINI(4,2) = EE2
4473         PINI(5,2) = 0.D0
4474 C  outgoing electron 2
4475         YQ2 = SQRT((1.D0-Y2)*Q2P2)
4476         Q2E = Q2P2/(4.D0*EE2)
4477         E1Y = EE2*(1.D0-Y2)
4478         CALL PHO_SFECFE(SIF,COF)
4479         PFIN(1,2) = YQ2*COF
4480         PFIN(2,2) = YQ2*SIF
4481         PFIN(3,2) = -E1Y+Q2E
4482         PFIN(4,2) = E1Y+Q2E
4483         PFIN(5,2) = 0.D0
4484 C  photon 2
4485         P2(1) = -PFIN(1,2)
4486         P2(2) = -PFIN(2,2)
4487         P2(3) = PINI(3,2)-PFIN(3,2)
4488         P2(4) = PINI(4,2)-PFIN(4,2)
4489 C  ECMS cut
4490         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4491      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4492         IF(GGECM.LT.0.1D0) GOTO 175
4493         GGECM = SQRT(GGECM)
4494         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4495
4496         PGAM(1,1) = P1(1)
4497         PGAM(2,1) = P1(2)
4498         PGAM(3,1) = P1(3)
4499         PGAM(4,1) = P1(4)
4500         PGAM(5,1) = 0.D0
4501         PGAM(1,2) = P2(1)
4502         PGAM(2,2) = P2(2)
4503         PGAM(3,2) = P2(3)
4504         PGAM(4,2) = P2(4)
4505         PGAM(5,2) = 0.D0
4506 C  photon helicities
4507         IGHEL(1) = 1
4508         IGHEL(2) = 1
4509 C  cut given by user
4510         CALL PHO_PRESEL(5,IREJ)
4511         IF(IREJ.NE.0) GOTO 175
4512 C  event generation
4513         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4514         IF(IREJ.NE.0) GOTO 150
4515
4516 C  statistics
4517         AY1  = AY1+Y1
4518         AYS1 = AYS1+Y1*Y1
4519         AY2  = AY2+Y2
4520         AYS2 = AYS2+Y2*Y2
4521 C  histograms
4522         CALL PHO_PHIST(1,HSWGHT(0))
4523         CALL PHO_LHIST(1,HSWGHT(0))
4524  200  CONTINUE
4525
4526       WGY  = DBLE(ITRY)/DBLE(ITRW)
4527       AY1  = AY1/DBLE(NITER)
4528       AYS1 = AYS1/DBLE(NITER)
4529       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4530       AY2  = AY2/DBLE(NITER)
4531       AYS2 = AYS2/DBLE(NITER)
4532       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4533       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4534 C  output of statistics, histograms
4535       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4536      &'=========================================================',
4537      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
4538      &'========================================================='
4539       WRITE(LO,'(//1X,A,3I10)')
4540      &  'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
4541       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4542      &  WGY,WEIGHT
4543       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
4544       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
4545
4546       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4547       IF(NITER.GT.1) THEN
4548         CALL PHO_PHIST(-2,WEIGHT)
4549         CALL PHO_LHIST(-2,WEIGHT)
4550       ELSE
4551         WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
4552       ENDIF
4553
4554       END
4555
4556 *$ CREATE pho_samp1d.FOR
4557 *COPY pho_samp1d
4558 CDECK  ID>, pho_samp1d
4559       SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
4560 C***********************************************************************
4561 C
4562 C     Monte Carlo sampling from arbitrary 1d distribution
4563 C     (linear interpolation to improve reproduction of initial function)
4564 C
4565 C     input: Imode          -1  initialization
4566 C                            1  sampling (after initialization)
4567 C            X_inp(N_dim)   array with x values
4568 C            F_inp(N_dim)   array with function values
4569 C            F_int(N_dim)   array with integral
4570 C
4571 C     output:  X_out        sampled value (Imode=1)
4572 C
4573 C                                                 (R.E. 10/99)
4574 C
4575 C***********************************************************************
4576       implicit none
4577       save
4578
4579 C  input/output channels
4580       INTEGER LI,LO
4581       COMMON /POINOU/ LI,LO
4582
4583       integer Imode,N_dim
4584       double precision X_inp,F_inp,F_int,X_out
4585       dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
4586
4587 C  local variables
4588       integer i
4589       double precision dum,xi,a,b
4590
4591 C  external functions
4592       double precision DT_RNDM
4593       external DT_RNDM
4594
4595       if(Imode.eq.-1) then
4596
4597 C  initialization
4598
4599         F_int(1) = 0.D0
4600         do i=2,N_dim
4601           F_int(i) = F_int(i-1)
4602      &       +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
4603         enddo
4604
4605       else if(Imode.eq.1) then
4606
4607 C  sample from previously calculated integral
4608
4609         xi = DT_RNDM(dum)*F_int(N_dim)
4610
4611         do i=2,N_dim
4612           if(xi.lt.F_int(i)) then
4613             a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
4614             b = F_inp(i)-a*X_inp(i)
4615             xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
4616             X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
4617             return
4618           endif
4619         enddo
4620         X_out = X_inp(N_dim)
4621
4622       else
4623
4624 C  invalid option Imode
4625
4626         WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
4627         X_out = 0.D0
4628
4629       endif
4630
4631       END
4632
4633 *$ CREATE pho_ExpBessI0.FOR
4634 *COPY pho_ExpBessI0
4635 CDECK  ID>, pho_ExpBessI0
4636       DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
4637 C**********************************************************************
4638 C
4639 C     Bessel Function I0 times exponential function from neg. arg.
4640 C     (defined for pos. arguments only)
4641 C
4642 C**********************************************************************
4643       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4644       SAVE
4645
4646       AX = ABS(X)
4647       IF (AX .LT. 3.75D0) THEN
4648         Y = (X/3.75D0)**2
4649         pho_ExpBessI0 =
4650      &    (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
4651      &    +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
4652       ELSE
4653         Y = 3.75D0/AX
4654         pho_ExpBessI0 =
4655      &    (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
4656      &    +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
4657      &    +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
4658      &    +Y*0.392377D-2))))))))
4659       ENDIF
4660
4661       END
4662
4663 *$ CREATE PHO_GGBEAM.FOR
4664 *COPY PHO_GGBEAM
4665 CDECK  ID>, PHO_GGBEAM
4666       SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
4667 C**********************************************************************
4668 C
4669 C     interface to call PHOJET (variable energy run) for
4670 C     gamma-gamma collisions via beamstrahlung
4671 C
4672 C     input:     EE      LAB system energy of electron/positron
4673 C                YPSI    beamstrahlung parameter
4674 C                SIGX,Y  transverse bunch dimensions
4675 C                SIGZ    longitudinal bunch dimension
4676 C                AEB     number of electrons/positrons in a bunch
4677 C                NEVENT  number of events to generate
4678 C            from /LEPCUT/:
4679 C                YMIN1   lower limit of Y
4680 C                        (energy fraction taken by photon from electron)
4681 C                YMAX1   upper cutoff for Y, necessary to avoid
4682 C                        underflows
4683 C
4684 C**********************************************************************
4685       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4686       SAVE
4687
4688       PARAMETER ( DEPS = 1.D-20,
4689      &            PI   = 3.14159265359D0 )
4690
4691 C  input/output channels
4692       INTEGER LI,LO
4693       COMMON /POINOU/ LI,LO
4694 C  event debugging information
4695       INTEGER NMAXD
4696       PARAMETER (NMAXD=100)
4697       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4698      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4699       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4700      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4701 C  photon flux kinematics and cuts
4702       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4703      &                 YMIN1,YMAX1,YMIN2,YMAX2,
4704      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4705      &                 THMIN1,THMAX1,THMIN2,THMAX2
4706       INTEGER          ITAG1,ITAG2
4707       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4708      &                YMIN1,YMAX1,YMIN2,YMAX2,
4709      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4710      &                THMIN1,THMAX1,THMIN2,THMAX2,
4711      &                ITAG1,ITAG2
4712 C  gamma-lepton or gamma-hadron vertex information
4713       INTEGER IGHEL,IDPSRC,IDBSRC
4714       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4715      &                 RADSRC,AMSRC,GAMSRC
4716       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4717      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4718      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4719 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
4720       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4721       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4722       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4723      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4724 C  event weights and generated cross section
4725       INTEGER IPOWGC,ISWCUT,IVWGHT
4726       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4727       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4728      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4729
4730       PARAMETER (Max_tab=100)
4731       DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
4732
4733 C
4734       WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
4735 C  electron data
4736       RE = 2.818D-12
4737       ELEM = 0.512D-03
4738       IDPSRC(1) = 0
4739       IDBSRC(1) = 0
4740       IDPSRC(2) = 0
4741       IDBSRC(2) = 0
4742 C  table of flux function, log interpolation
4743       IF(YPSI.LE.0.D0) THEN
4744         YPSI  = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
4745       ENDIF
4746       WRITE(LO,'(/1X,A,E12.4)')
4747      &  'PHO_GGBEAM: beamstrahlung parameter:',YPSI
4748       WRITE(LO,'(/1X,A,2E12.4)')
4749      &  'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
4750       TT    = 2.D0/3.D0
4751       OT    = 1.D0/3.D0
4752 C     GAOT  = DGAMMA(OT)
4753       GAOT  = 2.6789385347D0
4754       AKAP  = TT/YPSI
4755       WW    = 1.D0/(6.D0*SQRT(AKAP))
4756       ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
4757      &       *YPSI/SQRT(1.D0+YPSI**TT)
4758
4759       YMIN = YMIN1
4760       YMAX = MIN(YMAX1,0.9D0)
4761       TABCU(0) = 0.D0
4762       TABYL(0) = LOG(YMIN)
4763       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
4764       FLUX = 0.D0
4765       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4766      &  'PHO_GGBEAM: table of photon flux',Max_tab
4767       DO 100 I=1,Max_tab
4768         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
4769         GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
4770         FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
4771      &      *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
4772      &      +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
4773         TABCU(I) = TABCU(I-1)+FF*Y
4774         TABYL(I) = LOG(Y)
4775         FLUX = FLUX+Y*FF
4776         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
4777  100  CONTINUE
4778       FLUX = FLUX*DELLY
4779       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
4780      &  'PHO_GGBEAM: integrated flux (one side):',FLUX
4781
4782       EE1 = EE
4783       EE2 = EE
4784 C  photon 1
4785       EGAM = YMAX*EE
4786       P1(1) = 0.D0
4787       P1(2) = 0.D0
4788       P1(3) = EGAM
4789       P1(4) = EGAM
4790 C  photon 2
4791       EGAM = YMAX*EE
4792       P2(1) = 0.D0
4793       P2(2) = 0.D0
4794       P2(3) = -EGAM
4795       P2(4) = EGAM
4796       CALL PHO_SETPAR(1,22,0,0.D0)
4797       CALL PHO_SETPAR(2,22,0,0.D0)
4798       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4799       CALL PHO_PHIST(-1,SIGMAX)
4800       CALL PHO_LHIST(-1,SIGMAX)
4801
4802 C  generation of events
4803
4804       AY1  = 0.D0
4805       AY2  = 0.D0
4806       AYS1 = 0.D0
4807       AYS2 = 0.D0
4808       NITER = NEVENT
4809       ITRY = 0
4810       ITRW = 0
4811       DO 200 I=1,NITER
4812  150    CONTINUE
4813         ITRY = ITRY+1
4814  175    CONTINUE
4815         ITRW = ITRW+1
4816         XI = DT_RNDM(AY1)*TABCU(Max_tab)
4817         DO 110 K=1,Max_tab
4818           IF(TABCU(K).GE.XI) THEN
4819             Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4820             Y1 = EXP(Y1)
4821             GOTO 120
4822           ENDIF
4823  110    CONTINUE
4824         Y1 = YMAX
4825  120    CONTINUE
4826         XI = DT_RNDM(AY2)*TABCU(Max_tab)
4827         DO 130 K=1,Max_tab
4828           IF(TABCU(K).GE.XI) THEN
4829             Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4830             Y2 = EXP(Y2)
4831             GOTO 140
4832           ENDIF
4833  130    CONTINUE
4834         Y2 = YMAX
4835  140    CONTINUE
4836
4837         Q2P1 = 0.D0
4838         Q2P2 = 0.D0
4839         GYY(1) = Y1
4840         GQ2(1) = Q2P1
4841         GYY(2) = Y2
4842         GQ2(2) = Q2P2
4843 C  incoming electron 1
4844         PINI(1,1) = 0.D0
4845         PINI(2,1) = 0.D0
4846         PINI(3,1) = EE1
4847         PINI(4,1) = EE1
4848         PINI(5,1) = 0.D0
4849 C  outgoing electron 1
4850         YQ2 = SQRT((1.D0-Y1)*Q2P2)
4851         Q2E = Q2P1/(4.D0*EE1)
4852         E1Y = EE1*(1.D0-Y1)
4853         CALL PHO_SFECFE(SIF,COF)
4854         PFIN(1,1) = YQ2*COF
4855         PFIN(2,1) = YQ2*SIF
4856         PFIN(3,1) = E1Y-Q2E
4857         PFIN(4,1) = E1Y+Q2E
4858         PFIN(5,1) = 0.D0
4859 C  photon 1
4860         P1(1) = -PFIN(1,1)
4861         P1(2) = -PFIN(2,1)
4862         P1(3) = PINI(3,1)-PFIN(3,1)
4863         P1(4) = PINI(4,1)-PFIN(4,1)
4864 C  incoming electron 2
4865         PINI(1,2) = 0.D0
4866         PINI(2,2) = 0.D0
4867         PINI(3,2) = -EE2
4868         PINI(4,2) = EE2
4869         PINI(5,2) = 0.D0
4870 C  outgoing electron 2
4871         YQ2 = SQRT((1.D0-Y2)*Q2P2)
4872         Q2E = Q2P2/(4.D0*EE2)
4873         E1Y = EE2*(1.D0-Y2)
4874         CALL PHO_SFECFE(SIF,COF)
4875         PFIN(1,2) = YQ2*COF
4876         PFIN(2,2) = YQ2*SIF
4877         PFIN(3,2) = -E1Y+Q2E
4878         PFIN(4,2) = E1Y+Q2E
4879         PFIN(5,2) = 0.D0
4880 C  photon 2
4881         P2(1) = -PFIN(1,2)
4882         P2(2) = -PFIN(2,2)
4883         P2(3) = PINI(3,2)-PFIN(3,2)
4884         P2(4) = PINI(4,2)-PFIN(4,2)
4885 C  ECMS cut
4886         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4887      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4888         IF(GGECM.LT.0.1D0) GOTO 175
4889         GGECM = SQRT(GGECM)
4890         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4891 C
4892         PGAM(1,1) = P1(1)
4893         PGAM(2,1) = P1(2)
4894         PGAM(3,1) = P1(3)
4895         PGAM(4,1) = P1(4)
4896         PGAM(5,1) = 0.D0
4897         PGAM(1,2) = P2(1)
4898         PGAM(2,2) = P2(2)
4899         PGAM(3,2) = P2(3)
4900         PGAM(4,2) = P2(4)
4901         PGAM(5,2) = 0.D0
4902 C  photon helicities
4903         IGHEL(1) = 1
4904         IGHEL(2) = 1
4905 C  cut given by user
4906         CALL PHO_PRESEL(5,IREJ)
4907         IF(IREJ.NE.0) GOTO 175
4908 C  event generation
4909         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4910         IF(IREJ.NE.0) GOTO 150
4911 **sr leading tab removed
4912         GGECML = LOG(GGECM)
4913 **
4914
4915 C  statistics
4916         AY1  = AY1+Y1
4917         AYS1 = AYS1+Y1*Y1
4918         AY2  = AY2+Y2
4919         AYS2 = AYS2+Y2*Y2
4920 C  histograms
4921         CALL PHO_PHIST(1,HSWGHT(0))
4922         CALL PHO_LHIST(1,HSWGHT(0))
4923  200  CONTINUE
4924 C
4925       WGY  = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
4926       AY1  = AY1/DBLE(NITER)
4927       AYS1 = AYS1/DBLE(NITER)
4928       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4929       AY2  = AY2/DBLE(NITER)
4930       AYS2 = AYS2/DBLE(NITER)
4931       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4932       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4933 C  output of statistics, histograms
4934       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4935      &'=========================================================',
4936      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
4937      &'========================================================='
4938       WRITE(LO,'(//1X,A,2I10)')
4939      &  'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
4940       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4941      &  WGY,WEIGHT
4942       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
4943       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
4944 C
4945       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4946       IF(NITER.GT.1) THEN
4947         CALL PHO_PHIST(-2,WEIGHT)
4948         CALL PHO_LHIST(-2,WEIGHT)
4949       ELSE
4950         WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
4951       ENDIF
4952
4953       END
4954
4955 *$ CREATE PHO_GGHIOF.FOR
4956 *COPY PHO_GGHIOF
4957 CDECK  ID>, PHO_GGHIOF
4958       SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
4959 C**********************************************************************
4960 C
4961 C     interface to call PHOJET (variable energy run) for
4962 C     gamma-gamma collisions via heavy ions (form factor approach)
4963 C
4964 C     input:     EEN     LAB system energy per nucleon
4965 C                NA      atomic number of ion/hadron
4966 C                NZ      charge number of ion/hadron
4967 C                NEVENT  number of events to generate
4968 C            from /LEPCUT/:
4969 C                YMIN1,2 lower limit of Y
4970 C                        (energy fraction taken by photon from hadron)
4971 C                YMAX1,2 upper cutoff for Y, necessary to avoid
4972 C                        underflows
4973 C                Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
4974 C                Q2MAX1,2 maximum Q**2 of photons (if necessary,
4975 C                        corrected according size of hadron)
4976 C
4977 C      currently implemented approximation similar to:
4978 C                E.Papageorgiu PhysLettB250(1990)155
4979 C
4980 C**********************************************************************
4981       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4982       SAVE
4983
4984       PARAMETER ( PI   = 3.14159265359D0 )
4985
4986 C  input/output channels
4987       INTEGER LI,LO
4988       COMMON /POINOU/ LI,LO
4989 C  model switches and parameters
4990       CHARACTER*8 MDLNA
4991       INTEGER ISWMDL,IPAMDL
4992       DOUBLE PRECISION PARMDL
4993       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4994 C  event debugging information
4995       INTEGER NMAXD
4996       PARAMETER (NMAXD=100)
4997       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4998      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4999       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5000      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5001 C  photon flux kinematics and cuts
5002       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5003      &                 YMIN1,YMAX1,YMIN2,YMAX2,
5004      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5005      &                 THMIN1,THMAX1,THMIN2,THMAX2
5006       INTEGER          ITAG1,ITAG2
5007       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5008      &                YMIN1,YMAX1,YMIN2,YMAX2,
5009      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5010      &                THMIN1,THMAX1,THMIN2,THMAX2,
5011      &                ITAG1,ITAG2
5012 C  gamma-lepton or gamma-hadron vertex information
5013       INTEGER IGHEL,IDPSRC,IDBSRC
5014       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5015      &                 RADSRC,AMSRC,GAMSRC
5016       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5017      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5018      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5019 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
5020       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5021       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5022       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5023      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5024 C  event weights and generated cross section
5025       INTEGER IPOWGC,ISWCUT,IVWGHT
5026       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5027       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5028      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5029
5030       DIMENSION P1(4),P2(4),BIMP(2,2)
5031
5032 C
5033       WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
5034      &                      '--------------------------------------'
5035 C  hadron size and mass
5036       FM2GEV = 5.07D0
5037       HIMASS = DBLE(NA)*0.938D0
5038       HIMA2  = HIMASS**2
5039       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5040       ALPHA  = DBLE(NZ**2)/137.D0
5041 C  correct Q2MAX1,2 according to hadron size
5042       Q2MAXH = 2.D0/HIRADI**2
5043       Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
5044       Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
5045       IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
5046       IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
5047 C  total hadron / heavy ion energy
5048       EE = EEN*DBLE(NA)
5049       GAMMA = EE/HIMASS
5050 C  setup /POFSRC/
5051       GAMSRC(1) = GAMMA
5052       GAMSRC(2) = GAMMA
5053       RADSRC(1) = HIRADI
5054       RADSRC(2) = HIRADI
5055       AMSRC(1)  = HIMASS
5056       AMSRC(1)  = HIMASS
5057 C  kinematic limitations
5058       YMI = (ECMIN/(2.D0*EE))**2
5059       IF(YMIN1.LT.YMI) THEN
5060         WRITE(LO,'(/1X,A,2E12.5)')
5061      &    'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
5062         YMIN1 = YMI
5063       ELSE IF(YMIN1.GT.YMI) THEN
5064         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5065      &    'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5066      &    '  INSTEAD OF',YMIN1
5067       ENDIF
5068       IF(YMIN2.LT.YMI) THEN
5069         WRITE(LO,'(/1X,A,2E12.5)')
5070      &    'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
5071         YMIN2 = YMI
5072       ELSE IF(YMIN2.GT.YMI) THEN
5073         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5074      &    'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5075      &    '  INSTEAD OF',YMIN2
5076       ENDIF
5077 C  kinematic limitation
5078       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5079       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5080 C  debug output
5081       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
5082       WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
5083       WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
5084       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
5085      &  Q2MAX1
5086       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
5087      &  Q2MAX2
5088       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
5089      &  YMAX1
5090       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
5091      &  YMAX2
5092       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
5093      &  2.D0*EEN,2.D0*EE
5094       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
5095       IF(Q2LOW1.GE.Q2MAX1) THEN
5096         WRITE(LO,'(/1X,A,2E12.4)')
5097      &    'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
5098         CALL PHO_ABORT
5099       ENDIF
5100       IF(Q2LOW2.GE.Q2MAX2) THEN
5101         WRITE(LO,'(/1X,A,2E12.4)')
5102      &    'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
5103         CALL PHO_ABORT
5104       ENDIF
5105 C  hadron numbers set to 0
5106       IDPSRC(1) = 0
5107       IDPSRC(2) = 0
5108       IDBSRC(1) = 0
5109       IDBSRC(2) = 0
5110 C
5111       Max_tab = 100
5112       YMAX = YMAX1
5113       YMIN = YMIN1
5114       XMAX = LOG(YMAX)
5115       XMIN = LOG(YMIN)
5116       XDEL = XMAX-XMIN
5117       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5118       DO 100 I=1,Max_tab
5119         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5120         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5121         IF(Q2LOW1.GE.Q2MAX1) THEN
5122           WRITE(LO,'(/1X,A,2E12.4)')
5123      &      'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
5124           YMAX1 = MIN(Y1,YMAX1)
5125           GOTO 101
5126         ENDIF
5127  100  CONTINUE
5128  101  CONTINUE
5129       YMAX = YMAX2
5130       YMIN = YMIN2
5131       XMAX = LOG(YMAX)
5132       XMIN = LOG(YMIN)
5133       XDEL = XMAX-XMIN
5134       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5135       DO 102 I=1,Max_tab
5136         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5137         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
5138         IF(Q2LOW2.GE.Q2MAX2) THEN
5139           WRITE(LO,'(/1X,A,2E12.4)')
5140      &      'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
5141           YMAX2 = MIN(Y1,YMAX2)
5142           GOTO 103
5143         ENDIF
5144  102  CONTINUE
5145  103  CONTINUE
5146       YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5147       IF(YMI.GT.YMIN1) THEN
5148         WRITE(LO,'(/1X,A,2E12.4)')
5149      &    'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
5150         YMIN1 = YMI
5151       ENDIF
5152       YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5153       IF(YMI.GT.YMIN2) THEN
5154         WRITE(LO,'(/1X,A,2E12.4)')
5155      &    'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
5156         YMIN2 = YMI
5157       ENDIF
5158 C
5159       X1MAX = LOG(YMAX1)
5160       X1MIN = LOG(YMIN1)
5161       X1DEL = X1MAX-X1MIN
5162       X2MAX = LOG(YMAX2)
5163       X2MIN = LOG(YMIN2)
5164       X2DEL = X2MAX-X2MIN
5165       DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
5166       FLUX = 0.D0
5167       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5168      &  'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
5169       DO 105 I=1,Max_tab
5170         Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
5171         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5172         FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
5173      &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
5174         FLUX = FLUX+Y1*FF
5175         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
5176  105  CONTINUE
5177       FLUX = FLUX*DELLY
5178       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5179      &  'PHO_GGHIOF: integrated flux (one side):',FLUX
5180 C
5181       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5182       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5183       Y1 = YMIN1
5184       Y2 = YMIN2
5185       WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
5186      &         -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5187      &       *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
5188      &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5189 C
5190 C  photon 1
5191       EGAM = YMAX1*EE
5192       P1(1) = 0.D0
5193       P1(2) = 0.D0
5194       P1(3) = EGAM
5195       P1(4) = EGAM
5196 C  photon 2
5197       EGAM = YMAX2*EE
5198       P2(1) = 0.D0
5199       P2(2) = 0.D0
5200       P2(3) = -EGAM
5201       P2(4) = EGAM
5202       CALL PHO_SETPAR(1,22,0,0.D0)
5203       CALL PHO_SETPAR(2,22,0,0.D0)
5204       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5205       CALL PHO_PHIST(-1,SIGMAX)
5206       CALL PHO_LHIST(-1,SIGMAX)
5207 C
5208 C  generation of events, flux calculation
5209
5210       ECFRAC = ECMIN**2/(4.D0*EE*EE)
5211       AY1  = 0.D0
5212       AY2  = 0.D0
5213       AYS1 = 0.D0
5214       AYS2 = 0.D0
5215       Q21MIN = 1.D30
5216       Q22MIN = 1.D30
5217       Q21MAX = 0.D0
5218       Q22MAX = 0.D0
5219       Q21AVE = 0.D0
5220       Q22AVE = 0.D0
5221       Q21AV2 = 0.D0
5222       Q22AV2 = 0.D0
5223       YY1MIN = 1.D30
5224       YY2MIN = 1.D30
5225       YY1MAX = 0.D0
5226       YY2MAX = 0.D0
5227       NITER = NEVENT
5228       ITRY = 0
5229       ITRW = 0
5230       DO 200 I=1,NITER
5231 C  sample y1, y2
5232  150    CONTINUE
5233         ITRY = ITRY+1
5234  175    CONTINUE
5235           ITRW = ITRW+1
5236           Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
5237           Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
5238           IF(Y1*Y2.LT.ECFRAC) GOTO 175
5239 C
5240           Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
5241           IF(Q2LOW1.GE.Q2MAX1) GOTO 175
5242           Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
5243           IF(Q2LOW2.GE.Q2MAX2) GOTO 175
5244           Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
5245           Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
5246           WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
5247      &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5248      &         *((1.D0+(1.D0-Y2)**2)*Q2LOG2
5249      &        -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5250           IF(WGMAX.LT.WGH) THEN
5251             WRITE(LO,'(1X,A,4E12.5)')
5252      &        'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
5253           ENDIF
5254         IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
5255 C  sample Q2
5256         IF(IPAMDL(174).EQ.1) THEN
5257           YEFF = 1.D0+(1.D0-Y1)**2
5258  185      CONTINUE
5259             Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
5260             WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
5261           IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
5262         ELSE
5263           Q2P1 = Q2LOW1
5264         ENDIF
5265         IF(IPAMDL(174).EQ.1) THEN
5266           YEFF = 1.D0+(1.D0-Y2)**2
5267  186      CONTINUE
5268             Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
5269             WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
5270           IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
5271         ELSE
5272           Q2P2 = Q2LOW2
5273         ENDIF
5274 C  impact parameter
5275         GAIMP(1) = 1.D0/SQRT(Q2P1)
5276         GAIMP(2) = 1.D0/SQRT(Q2P2)
5277 C  form factor (squared)
5278         FF21 = 1.D0
5279         IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
5280         FF22 = 1.D0
5281         IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
5282         IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
5283 C  do the hadrons overlap?
5284         IF(ISWMDL(26).GT.0) THEN
5285           DO 190 K=1,2
5286             CALL PHO_SFECFE(SIF,COF)
5287             BIMP(1,K) = SIF*GAIMP(K)
5288             BIMP(2,K) = COF*GAIMP(K)
5289  190      CONTINUE
5290           BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
5291      &                 +(BIMP(2,1)-BIMP(2,2))**2)
5292           IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
5293         ENDIF
5294 C  photon data
5295         GYY(1) = Y1
5296         GQ2(1) = Q2P1
5297         GYY(2) = Y2
5298         GQ2(2) = Q2P2
5299 C
5300
5301 C  incoming hadron 1
5302         PINI(1,1) = 0.D0
5303         PINI(2,1) = 0.D0
5304         PINI(3,1) = EE
5305         PINI(4,1) = EE
5306         PINI(5,1) = 0.D0
5307 C  outgoing hadron 1
5308         YQ2 = SQRT((1.D0-Y1)*Q2P1)
5309         Q2E = Q2P1/(4.D0*EE)
5310         E1Y = EE*(1.D0-Y1)
5311         CALL PHO_SFECFE(SIF,COF)
5312         PFIN(1,1) = YQ2*COF
5313         PFIN(2,1) = YQ2*SIF
5314         PFIN(3,1) = E1Y-Q2E
5315         PFIN(4,1) = E1Y+Q2E
5316         PFIN(5,1) = 0.D0
5317         PFPHI(1) = ATAN2(COF,SIF)
5318         PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
5319 C  photon 1
5320         P1(1) = -PFIN(1,1)
5321         P1(2) = -PFIN(2,1)
5322         P1(3) = PINI(3,1)-PFIN(3,1)
5323         P1(4) = PINI(4,1)-PFIN(4,1)
5324 C  incoming hadron 2
5325         PINI(1,2) = 0.D0
5326         PINI(2,2) = 0.D0
5327         PINI(3,2) = -EE
5328         PINI(4,2) = EE
5329         PINI(5,2) = 0.D0
5330 C  outgoing hadron 2
5331         YQ2 = SQRT((1.D0-Y2)*Q2P2)
5332         Q2E = Q2P2/(4.D0*EE)
5333         E1Y = EE*(1.D0-Y2)
5334         CALL PHO_SFECFE(SIF,COF)
5335         PFIN(1,2) = YQ2*COF
5336         PFIN(2,2) = YQ2*SIF
5337         PFIN(3,2) = -E1Y+Q2E
5338         PFIN(4,2) = E1Y+Q2E
5339         PFIN(5,2) = 0.D0
5340         PFPHI(2) = ATAN2(COF,SIF)
5341         PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
5342 C  photon 2
5343         P2(1) = -PFIN(1,2)
5344         P2(2) = -PFIN(2,2)
5345         P2(3) = PINI(3,2)-PFIN(3,2)
5346         P2(4) = PINI(4,2)-PFIN(4,2)
5347 C  ECMS cut
5348         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
5349      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
5350         IF(GGECM.LT.0.1D0) GOTO 175
5351         GGECM = SQRT(GGECM)
5352         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5353 C
5354         PGAM(1,1) = P1(1)
5355         PGAM(2,1) = P1(2)
5356         PGAM(3,1) = P1(3)
5357         PGAM(4,1) = P1(4)
5358         PGAM(5,1) = -SQRT(Q2P1)
5359         PGAM(1,2) = P2(1)
5360         PGAM(2,2) = P2(2)
5361         PGAM(3,2) = P2(3)
5362         PGAM(4,2) = P2(4)
5363         PGAM(5,2) = -SQRT(Q2P2)
5364 C  photon helicities
5365         IGHEL(1) = 1
5366         IGHEL(2) = 1
5367 C  cut given by user
5368         CALL PHO_PRESEL(5,IREJ)
5369         IF(IREJ.NE.0) GOTO 175
5370 C  event generation
5371         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5372         IF(IREJ.NE.0) GOTO 150
5373
5374 C  statistics
5375         AY1  = AY1+Y1
5376         AYS1 = AYS1+Y1*Y1
5377         AY2  = AY2+Y2
5378         AYS2 = AYS2+Y2*Y2
5379         Q21MIN = MIN(Q21MIN,Q2P1)
5380         Q22MIN = MIN(Q22MIN,Q2P2)
5381         Q21MAX = MAX(Q21MAX,Q2P1)
5382         Q22MAX = MAX(Q22MAX,Q2P2)
5383         YY1MIN = MIN(YY1MIN,Y1)
5384         YY2MIN = MIN(YY2MIN,Y2)
5385         YY1MAX = MAX(YY1MAX,Y1)
5386         YY2MAX = MAX(YY2MAX,Y2)
5387         Q21AVE = Q21AVE+Q2P1
5388         Q22AVE = Q22AVE+Q2P2
5389         Q21AV2 = Q21AV2+Q2P1*Q2P1
5390         Q22AV2 = Q22AV2+Q2P2*Q2P2
5391 C  histograms
5392         CALL PHO_PHIST(1,HSWGHT(0))
5393         CALL PHO_LHIST(1,HSWGHT(0))
5394  200  CONTINUE
5395 C
5396       WGY  = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
5397       WGY  = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
5398       AY1  = AY1/DBLE(NITER)
5399       AYS1 = AYS1/DBLE(NITER)
5400       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5401       AY2  = AY2/DBLE(NITER)
5402       AYS2 = AYS2/DBLE(NITER)
5403       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5404       Q21AVE = Q21AVE/DBLE(NITER)
5405       Q21AV2 = Q21AV2/DBLE(NITER)
5406       Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
5407       Q22AVE = Q22AVE/DBLE(NITER)
5408       Q22AV2 = Q22AV2/DBLE(NITER)
5409       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
5410       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5411 C  output of statistics, histograms
5412       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5413      &'=========================================================',
5414      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
5415      &'========================================================='
5416       WRITE(LO,'(//1X,A,3I10)')
5417      &  'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5418       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5419      &  WGY,WEIGHT
5420       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
5421      &  AY1,DAY1
5422       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
5423      &  AY2,DAY2
5424       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
5425      &  YY1MIN,YY1MAX
5426       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
5427      &  YY2MIN,YY2MAX
5428       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1      ',
5429      &  Q21AVE,Q21AV2
5430       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1    ',
5431      &  Q21MIN,Q21MAX
5432       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
5433      &  Q22AVE,Q22AV2
5434       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
5435      &  Q22MIN,Q22MAX
5436 C
5437       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5438       IF(NITER.GT.1) THEN
5439         CALL PHO_PHIST(-2,WEIGHT)
5440         CALL PHO_LHIST(-2,WEIGHT)
5441       ELSE
5442         WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
5443       ENDIF
5444
5445       END
5446
5447 *$ CREATE PHO_GGHIOG.FOR
5448 *COPY PHO_GGHIOG
5449 CDECK  ID>, PHO_GGHIOG
5450       SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
5451 C**********************************************************************
5452 C
5453 C     interface to call PHOJET (variable energy run) for
5454 C     gamma-gamma collisions via heavy ions (geometrical approach)
5455 C
5456 C
5457 C     input:     EEN     LAB system energy per nucleon
5458 C                NA      atomic number of ion/hadron
5459 C                NZ      charge number of ion/hadron
5460 C                NEVENT  number of events to generate
5461 C            from /LEPCUT/:
5462 C                YMIN1,2 lower limit of Y
5463 C                        (energy fraction taken by photon from hadron)
5464 C                YMAX1,2 upper cutoff for Y, necessary to avoid
5465 C                        underflows
5466 C
5467 C      currently implemented approximation similar to:
5468 C
5469 C
5470 C**********************************************************************
5471       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5472       SAVE
5473
5474       PARAMETER ( DEPS = 1.D-20,
5475      &            PI   = 3.14159265359D0 )
5476
5477 C  input/output channels
5478       INTEGER LI,LO
5479       COMMON /POINOU/ LI,LO
5480 C  event debugging information
5481       INTEGER NMAXD
5482       PARAMETER (NMAXD=100)
5483       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
5484      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5485       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5486      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5487 C  photon flux kinematics and cuts
5488       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5489      &                 YMIN1,YMAX1,YMIN2,YMAX2,
5490      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5491      &                 THMIN1,THMAX1,THMIN2,THMAX2
5492       INTEGER          ITAG1,ITAG2
5493       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5494      &                YMIN1,YMAX1,YMIN2,YMAX2,
5495      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5496      &                THMIN1,THMAX1,THMIN2,THMAX2,
5497      &                ITAG1,ITAG2
5498 C  gamma-lepton or gamma-hadron vertex information
5499       INTEGER IGHEL,IDPSRC,IDBSRC
5500       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5501      &                 RADSRC,AMSRC,GAMSRC
5502       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5503      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5504      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5505 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
5506       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5507       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5508       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5509      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5510 C  event weights and generated cross section
5511       INTEGER IPOWGC,ISWCUT,IVWGHT
5512       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5513       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5514      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5515
5516       PARAMETER (Max_tab=100)
5517       DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
5518
5519 C
5520       WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
5521      &                      '---------------------------------------'
5522 C  hadron size and mass
5523       FM2GEV = 5.07D0
5524       HIMASS = DBLE(NA)*0.938D0
5525       HIMA2  = HIMASS**2
5526       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5527       ALPHA  = DBLE(NZ**2)/137.D0
5528 C  total hadron / heavy ion energy
5529       EE     = EEN*DBLE(NA)
5530       GAMMA  = EE/HIMASS
5531 C  setup /POFSRC/
5532       GAMSRC(1) = GAMMA
5533       GAMSRC(2) = GAMMA
5534       RADSRC(1) = HIRADI
5535       RADSRC(2) = HIRADI
5536       AMSRC(1)  = HIMASS
5537       AMSRC(1)  = HIMASS
5538 C  kinematic limitations
5539       YMI = (ECMIN/(2.D0*EE))**2
5540       IF(YMIN1.LT.YMI) THEN
5541         WRITE(LO,'(/1X,A,2E12.5)')
5542      &    'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
5543         YMIN1 = YMI
5544       ELSE IF(YMIN1.GT.YMI) THEN
5545         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5546      &    'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5547      &    '  INSTEAD OF',YMIN1
5548       ENDIF
5549       IF(YMIN2.LT.YMI) THEN
5550         WRITE(LO,'(/1X,A,2E12.5)')
5551      &    'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
5552         YMIN2 = YMI
5553       ELSE IF(YMIN2.GT.YMI) THEN
5554         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5555      &    'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5556      &    '  INSTEAD OF',YMIN2
5557       ENDIF
5558 C  debug output
5559       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
5560       WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
5561       WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
5562       WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA               ',GAMMA
5563       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
5564      &  YMAX1
5565       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
5566      &  YMAX2
5567       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
5568      &  2.D0*EEN,2.D0*EE
5569       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
5570 C  hadron numbers set to 0
5571       IDPSRC(1) = 0
5572       IDBSRC(1) = 0
5573       IDPSRC(2) = 0
5574       IDBSRC(2) = 0
5575 C  table of flux function, log interpolation
5576       YMIN = YMIN1
5577       YMAX = YMAX1
5578       YMAX = MIN(YMAX,0.9999999D0)
5579       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5580       TABYL(0) = LOG(YMIN)
5581       FFMAX = 0.D0
5582       DO 100 I=1,Max_tab
5583         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5584         WG = EE*Y
5585         XI = WG*HIRADI/GAMMA
5586         FF = ALPHA*PHO_GGFLCL(XI)/Y
5587         FFMAX = MAX(FF,FFMAX)
5588         IF(FF.LT.1.D-10*FFMAX) THEN
5589           WRITE(LO,'(/1X,A,2E12.4)')
5590      &      'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
5591           YMAX1 = MIN(Y,YMAX1)
5592           GOTO 101
5593         ENDIF
5594  100  CONTINUE
5595  101  CONTINUE
5596       YMIN = YMIN2
5597       YMAX = YMAX2
5598       YMAX = MIN(YMAX,0.9999999D0)
5599       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5600       TABYL(0) = LOG(YMIN)
5601       FFMAX = 0.D0
5602       DO 102 I=1,Max_tab
5603         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5604         WG = EE*Y
5605         XI = WG*HIRADI/GAMMA
5606         FF = ALPHA*PHO_GGFLCL(XI)/Y
5607         FFMAX = MAX(FF,FFMAX)
5608         IF(FF.LT.1.D-10*FFMAX) THEN
5609           WRITE(LO,'(/1X,A,2E12.4)')
5610      &      'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
5611           YMAX2 = MIN(Y,YMAX2)
5612           GOTO 103
5613         ENDIF
5614  102  CONTINUE
5615  103  CONTINUE
5616       YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5617       IF(YMI.GT.YMIN1) THEN
5618         WRITE(LO,'(/1X,A,2E12.4)')
5619      &    'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
5620         YMIN1 = YMI
5621       ENDIF
5622       YMAX1 = MIN(YMAX,YMAX1)
5623       YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5624       IF(YMI.GT.YMIN2) THEN
5625         WRITE(LO,'(/1X,A,2E12.4)')
5626      &    'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
5627         YMIN2 = YMI
5628       ENDIF
5629 C
5630       YMIN = YMIN1
5631       YMAX = YMAX1
5632       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5633       TABCU(0) = 0.D0
5634       TABYL(0) = LOG(YMIN)
5635       FLUX = 0.D0
5636       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5637      &  'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
5638       DO 105 I=1,Max_tab
5639         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5640         WG = EE*Y
5641         XI = WG*HIRADI/GAMMA
5642         FF = ALPHA*PHO_GGFLCL(XI)/Y
5643         FFMAX = MAX(FF,FFMAX)
5644         TABCU(I) = TABCU(I-1)+FF*Y
5645         TABYL(I) = LOG(Y)
5646         FLUX = FLUX+Y*FF
5647         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
5648  105  CONTINUE
5649       FLUX = FLUX*DELLY
5650       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5651      &  'PHO_GGHIOG: integrated flux (one side):',FLUX
5652 C
5653 C  initialization
5654 C  photon 1
5655       EGAM = YMAX*EE
5656       P1(1) = 0.D0
5657       P1(2) = 0.D0
5658       P1(3) = EGAM
5659       P1(4) = EGAM
5660 C  photon 2
5661       EGAM = YMAX*EE
5662       P2(1) = 0.D0
5663       P2(2) = 0.D0
5664       P2(3) = -EGAM
5665       P2(4) = EGAM
5666       CALL PHO_SETPAR(1,22,0,0.D0)
5667       CALL PHO_SETPAR(2,22,0,0.D0)
5668       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5669       CALL PHO_PHIST(-1,SIGMAX)
5670       CALL PHO_LHIST(-1,SIGMAX)
5671 C
5672 C  generation of events
5673
5674       AY1  = 0.D0
5675       AY2  = 0.D0
5676       AYS1 = 0.D0
5677       AYS2 = 0.D0
5678       YY1MIN = 1.D30
5679       YY2MIN = 1.D30
5680       YY1MAX = 0.D0
5681       YY2MAX = 0.D0
5682       NITER = NEVENT
5683       ITRY = 0
5684       ITRW = 0
5685       DO 200 I=1,NITER
5686  150    CONTINUE
5687         ITRY = ITRY+1
5688  175    CONTINUE
5689         ITRW = ITRW+1
5690         XI = DT_RNDM(AY1)*TABCU(Max_tab)
5691         DO 110 K=1,Max_tab
5692           IF(TABCU(K).GE.XI) THEN
5693             Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5694             Y1 = EXP(Y1)
5695             GOTO 120
5696           ENDIF
5697  110    CONTINUE
5698         Y1 = YMAX1
5699  120    CONTINUE
5700         XI = DT_RNDM(AY2)*TABCU(Max_tab)
5701         DO 130 K=1,Max_tab
5702           IF(TABCU(K).GE.XI) THEN
5703             Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5704             Y2 = EXP(Y2)
5705             GOTO 140
5706           ENDIF
5707  130    CONTINUE
5708         Y2 = YMAX2
5709  140    CONTINUE
5710 C  setup kinematics
5711
5712         GYY(1) = Y1
5713         GQ2(1) = 0.D0
5714         GYY(2) = Y2
5715         GQ2(2) = 0.D0
5716 C  incoming electron 1
5717         PINI(1,1) = 0.D0
5718         PINI(2,1) = 0.D0
5719         PINI(3,1) = EE
5720         PINI(4,1) = EE
5721         PINI(5,1) = 0.D0
5722 C  outgoing electron 1
5723         E1Y = EE*(1.D0-Y1)
5724         PFIN(1,1) = 0.D0
5725         PFIN(2,1) = 0.D0
5726         PFIN(3,1) = E1Y
5727         PFIN(4,1) = E1Y
5728         PFIN(5,1) = 0.D0
5729 C  photon 1
5730         P1(1) = -PFIN(1,1)
5731         P1(2) = -PFIN(2,1)
5732         P1(3) = PINI(3,1)-PFIN(3,1)
5733         P1(4) = PINI(4,1)-PFIN(4,1)
5734 C  incoming electron 2
5735         PINI(1,2) = 0.D0
5736         PINI(2,2) = 0.D0
5737         PINI(3,2) = -EE
5738         PINI(4,2) = EE
5739         PINI(5,2) = 0.D0
5740 C  outgoing electron 2
5741         E1Y = EE*(1.D0-Y2)
5742         PFIN(1,2) = 0.D0
5743         PFIN(2,2) = 0.D0
5744         PFIN(3,2) = -E1Y
5745         PFIN(4,2) = E1Y
5746         PFIN(5,2) = 0.D0
5747 C  photon 2
5748         P2(1) = -PFIN(1,2)
5749         P2(2) = -PFIN(2,2)
5750         P2(3) = PINI(3,2)-PFIN(3,2)
5751         P2(4) = PINI(4,2)-PFIN(4,2)
5752 C  ECMS cut
5753         GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
5754         IF(GGECM.LT.0.1D0) GOTO 175
5755         GGECM = SQRT(GGECM)
5756         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5757         PGAM(1,1) = P1(1)
5758         PGAM(2,1) = P1(2)
5759         PGAM(3,1) = P1(3)
5760         PGAM(4,1) = P1(4)
5761         PGAM(5,1) = 0.D0
5762         PGAM(1,2) = P2(1)
5763         PGAM(2,2) = P2(2)
5764         PGAM(3,2) = P2(3)
5765         PGAM(4,2) = P2(4)
5766         PGAM(5,2) = 0.D0
5767 C  impact parameter constraints
5768         XI1   = P1(4)*HIRADI/GAMMA
5769         XI2   = P2(4)*HIRADI/GAMMA
5770         FLX   = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
5771         FCORR = PHO_GGFLCR(HIRADI)
5772         WGX   = (FLX-FCORR)/FLX
5773         IF(DT_RNDM(Y2).GT.WGX) GOTO 175
5774 C  photon helicities
5775         IGHEL(1) = 1
5776         IGHEL(2) = 1
5777 C  cut given by user
5778         CALL PHO_PRESEL(5,IREJ)
5779         IF(IREJ.NE.0) GOTO 175
5780 C  event generation
5781         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5782         IF(IREJ.NE.0) GOTO 150
5783
5784 C  statistics
5785         AY1  = AY1+Y1
5786         AYS1 = AYS1+Y1*Y1
5787         AY2  = AY2+Y2
5788         AYS2 = AYS2+Y2*Y2
5789         YY1MIN = MIN(YY1MIN,Y1)
5790         YY2MIN = MIN(YY2MIN,Y2)
5791         YY1MAX = MAX(YY1MAX,Y1)
5792         YY2MAX = MAX(YY2MAX,Y2)
5793 C  histograms
5794         CALL PHO_PHIST(1,HSWGHT(0))
5795         CALL PHO_LHIST(1,HSWGHT(0))
5796  200  CONTINUE
5797 C
5798       WGY  = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
5799       AY1  = AY1/DBLE(NITER)
5800       AYS1 = AYS1/DBLE(NITER)
5801       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5802       AY2  = AY2/DBLE(NITER)
5803       AYS2 = AYS2/DBLE(NITER)
5804       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5805       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5806 C  output of statistics, histograms
5807       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5808      &'=========================================================',
5809      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
5810      &'========================================================='
5811       WRITE(LO,'(//1X,A,3I12)')
5812      &  'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5813       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5814      &  WGY,WEIGHT
5815       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
5816      &  AY1,DAY1
5817       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
5818      &  AY2,DAY2
5819       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
5820      &  YY1MIN,YY1MAX
5821       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
5822      &  YY2MIN,YY2MAX
5823
5824 C
5825       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5826       IF(NITER.GT.1) THEN
5827         CALL PHO_PHIST(-2,WEIGHT)
5828         CALL PHO_LHIST(-2,WEIGHT)
5829       ELSE
5830         WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
5831       ENDIF
5832
5833       END
5834
5835 *$ CREATE PHO_GGFLCL.FOR
5836 *COPY PHO_GGFLCL
5837 CDECK  ID>, PHO_GGFLCL
5838       DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
5839 C*********************************************************************
5840 C
5841 C     semi-classical photon flux (geometrical model)
5842 C
5843 C*********************************************************************
5844       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5845       SAVE
5846
5847       PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
5848      &  -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
5849
5850       END
5851
5852 *$ CREATE PHO_GGFLCR.FOR
5853 *COPY PHO_GGFLCR
5854 CDECK  ID>, PHO_GGFLCR
5855       DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
5856 C*********************************************************************
5857 C
5858 C     semi-classical photon flux correction due to
5859 C     overlap in impact parameter space (geometrical model)
5860 C
5861 C*********************************************************************
5862       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5863       SAVE
5864
5865       PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
5866
5867 C  input/output channels
5868       INTEGER LI,LO
5869       COMMON /POINOU/ LI,LO
5870 C  gamma-lepton or gamma-hadron vertex information
5871       INTEGER IGHEL,IDPSRC,IDBSRC
5872       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5873      &                 RADSRC,AMSRC,GAMSRC
5874       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5875      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5876      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5877
5878       DIMENSION XGAUSS(126),WGAUSS(126)
5879
5880       DATA XGAUSS(1)/ .57735026918962576D0/
5881       DATA XGAUSS(2)/-.57735026918962576D0/
5882       DATA WGAUSS(1)/ 1.00000000000000000D0/
5883       DATA WGAUSS(2)/ 1.00000000000000000D0/
5884
5885       DATA XGAUSS(3)/ .33998104358485627D0/
5886       DATA XGAUSS(4)/ .86113631159405258D0/
5887       DATA XGAUSS(5)/-.33998104358485627D0/
5888       DATA XGAUSS(6)/-.86113631159405258D0/
5889       DATA WGAUSS(3)/ .65214515486254613D0/
5890       DATA WGAUSS(4)/ .34785484513745385D0/
5891       DATA WGAUSS(5)/ .65214515486254613D0/
5892       DATA WGAUSS(6)/ .34785484513745385D0/
5893
5894       DATA XGAUSS(7)/ .18343464249564981D0/
5895       DATA XGAUSS(8)/ .52553240991632899D0/
5896       DATA XGAUSS(9)/ .79666647741362674D0/
5897       DATA XGAUSS(10)/ .96028985649753623D0/
5898       DATA XGAUSS(11)/-.18343464249564981D0/
5899       DATA XGAUSS(12)/-.52553240991632899D0/
5900       DATA XGAUSS(13)/-.79666647741362674D0/
5901       DATA XGAUSS(14)/-.96028985649753623D0/
5902       DATA WGAUSS(7)/ .36268378337836198D0/
5903       DATA WGAUSS(8)/ .31370664587788727D0/
5904       DATA WGAUSS(9)/ .22238103445337448D0/
5905       DATA WGAUSS(10)/ .10122853629037627D0/
5906       DATA WGAUSS(11)/ .36268378337836198D0/
5907       DATA WGAUSS(12)/ .31370664587788727D0/
5908       DATA WGAUSS(13)/ .22238103445337448D0/
5909       DATA WGAUSS(14)/ .10122853629037627D0/
5910
5911       DATA XGAUSS(15)/ .0950125098376374402D0/
5912       DATA XGAUSS(16)/ .281603550779258913D0/
5913       DATA XGAUSS(17)/ .458016777657227386D0/
5914       DATA XGAUSS(18)/ .617876244402643748D0/
5915       DATA XGAUSS(19)/ .755404408355003034D0/
5916       DATA XGAUSS(20)/ .865631202387831744D0/
5917       DATA XGAUSS(21)/ .944575023073232576D0/
5918       DATA XGAUSS(22)/ .989400934991649933D0/
5919       DATA XGAUSS(23)/-.0950125098376374402D0/
5920       DATA XGAUSS(24)/-.281603550779258913D0/
5921       DATA XGAUSS(25)/-.458016777657227386D0/
5922       DATA XGAUSS(26)/-.617876244402643748D0/
5923       DATA XGAUSS(27)/-.755404408355003034D0/
5924       DATA XGAUSS(28)/-.865631202387831744D0/
5925       DATA XGAUSS(29)/-.944575023073232576D0/
5926       DATA XGAUSS(30)/-.989400934991649933D0/
5927       DATA WGAUSS(15)/ .189450610455068496D0/
5928       DATA WGAUSS(16)/ .182603415044923589D0/
5929       DATA WGAUSS(17)/ .169156519395002538D0/
5930       DATA WGAUSS(18)/ .149595988816576732D0/
5931       DATA WGAUSS(19)/ .124628971255533872D0/
5932       DATA WGAUSS(20)/ .0951585116824927848D0/
5933       DATA WGAUSS(21)/ .0622535239386478929D0/
5934       DATA WGAUSS(22)/ .0271524594117540949D0/
5935       DATA WGAUSS(23)/ .189450610455068496D0/
5936       DATA WGAUSS(24)/ .182603415044923589D0/
5937       DATA WGAUSS(25)/ .169156519395002538D0/
5938       DATA WGAUSS(26)/ .149595988816576732D0/
5939       DATA WGAUSS(27)/ .124628971255533872D0/
5940       DATA WGAUSS(28)/ .0951585116824927848D0/
5941       DATA WGAUSS(29)/ .0622535239386478929D0/
5942       DATA WGAUSS(30)/ .0271524594117540949D0/
5943
5944       DATA XGAUSS(31)/ .0483076656877383162D0/
5945       DATA XGAUSS(32)/ .144471961582796493D0/
5946       DATA XGAUSS(33)/ .239287362252137075D0/
5947       DATA XGAUSS(34)/ .331868602282127650D0/
5948       DATA XGAUSS(35)/ .421351276130635345D0/
5949       DATA XGAUSS(36)/ .506899908932229390D0/
5950       DATA XGAUSS(37)/ .587715757240762329D0/
5951       DATA XGAUSS(38)/ .663044266930215201D0/
5952       DATA XGAUSS(39)/ .732182118740289680D0/
5953       DATA XGAUSS(40)/ .794483795967942407D0/
5954       DATA XGAUSS(41)/ .849367613732569970D0/
5955       DATA XGAUSS(42)/ .896321155766052124D0/
5956       DATA XGAUSS(43)/ .934906075937739689D0/
5957       DATA XGAUSS(44)/ .964762255587506430D0/
5958       DATA XGAUSS(45)/ .985611511545268335D0/
5959       DATA XGAUSS(46)/ .997263861849481564D0/
5960       DATA XGAUSS(47)/-.0483076656877383162D0/
5961       DATA XGAUSS(48)/-.144471961582796493D0/
5962       DATA XGAUSS(49)/-.239287362252137075D0/
5963       DATA XGAUSS(50)/-.331868602282127650D0/
5964       DATA XGAUSS(51)/-.421351276130635345D0/
5965       DATA XGAUSS(52)/-.506899908932229390D0/
5966       DATA XGAUSS(53)/-.587715757240762329D0/
5967       DATA XGAUSS(54)/-.663044266930215201D0/
5968       DATA XGAUSS(55)/-.732182118740289680D0/
5969       DATA XGAUSS(56)/-.794483795967942407D0/
5970       DATA XGAUSS(57)/-.849367613732569970D0/
5971       DATA XGAUSS(58)/-.896321155766052124D0/
5972       DATA XGAUSS(59)/-.934906075937739689D0/
5973       DATA XGAUSS(60)/-.964762255587506430D0/
5974       DATA XGAUSS(61)/-.985611511545268335D0/
5975       DATA XGAUSS(62)/-.997263861849481564D0/
5976       DATA WGAUSS(31)/ .0965400885147278006D0/
5977       DATA WGAUSS(32)/ .0956387200792748594D0/
5978       DATA WGAUSS(33)/ .0938443990808045654D0/
5979       DATA WGAUSS(34)/ .0911738786957638847D0/
5980       DATA WGAUSS(35)/ .0876520930044038111D0/
5981       DATA WGAUSS(36)/ .0833119242269467552D0/
5982       DATA WGAUSS(37)/ .0781938957870703065D0/
5983       DATA WGAUSS(38)/ .0723457941088485062D0/
5984       DATA WGAUSS(39)/ .0658222227763618468D0/
5985       DATA WGAUSS(40)/ .0586840934785355471D0/
5986       DATA WGAUSS(41)/ .0509980592623761762D0/
5987       DATA WGAUSS(42)/ .0428358980222266807D0/
5988       DATA WGAUSS(43)/ .0342738629130214331D0/
5989       DATA WGAUSS(44)/ .0253920653092620595D0/
5990       DATA WGAUSS(45)/ .0162743947309056706D0/
5991       DATA WGAUSS(46)/ .00701861000947009660D0/
5992       DATA WGAUSS(47)/ .0965400885147278006D0/
5993       DATA WGAUSS(48)/ .0956387200792748594D0/
5994       DATA WGAUSS(49)/ .0938443990808045654D0/
5995       DATA WGAUSS(50)/ .0911738786957638847D0/
5996       DATA WGAUSS(51)/ .0876520930044038111D0/
5997       DATA WGAUSS(52)/ .0833119242269467552D0/
5998       DATA WGAUSS(53)/ .0781938957870703065D0/
5999       DATA WGAUSS(54)/ .0723457941088485062D0/
6000       DATA WGAUSS(55)/ .0658222227763618468D0/
6001       DATA WGAUSS(56)/ .0586840934785355471D0/
6002       DATA WGAUSS(57)/ .0509980592623761762D0/
6003       DATA WGAUSS(58)/ .0428358980222266807D0/
6004       DATA WGAUSS(59)/ .0342738629130214331D0/
6005       DATA WGAUSS(60)/ .0253920653092620595D0/
6006       DATA WGAUSS(61)/ .0162743947309056706D0/
6007       DATA WGAUSS(62)/ .00701861000947009660D0/
6008
6009       DATA XGAUSS(63)/ .02435029266342443250D0/
6010       DATA XGAUSS(64)/ .0729931217877990394D0/
6011       DATA XGAUSS(65)/ .121462819296120554D0/
6012       DATA XGAUSS(66)/ .169644420423992818D0/
6013       DATA XGAUSS(67)/ .217423643740007084D0/
6014       DATA XGAUSS(68)/ .264687162208767416D0/
6015       DATA XGAUSS(69)/ .311322871990210956D0/
6016       DATA XGAUSS(70)/ .357220158337668116D0/
6017       DATA XGAUSS(71)/ .402270157963991604D0/
6018       DATA XGAUSS(72)/ .446366017253464088D0/
6019       DATA XGAUSS(73)/ .489403145707052957D0/
6020       DATA XGAUSS(74)/ .531279464019894546D0/
6021       DATA XGAUSS(75)/ .571895646202634034D0/
6022       DATA XGAUSS(76)/ .611155355172393250D0/
6023       DATA XGAUSS(77)/ .648965471254657340D0/
6024       DATA XGAUSS(78)/ .685236313054233243D0/
6025       DATA XGAUSS(79)/ .719881850171610827D0/
6026       DATA XGAUSS(80)/ .752819907260531897D0/
6027       DATA XGAUSS(81)/ .783972358943341408D0/
6028       DATA XGAUSS(82)/ .813265315122797560D0/
6029       DATA XGAUSS(83)/ .840629296252580363D0/
6030       DATA XGAUSS(84)/ .865999398154092820D0/
6031       DATA XGAUSS(85)/ .889315445995114106D0/
6032       DATA XGAUSS(86)/ .910522137078502806D0/
6033       DATA XGAUSS(87)/ .929569172131939576D0/
6034       DATA XGAUSS(88)/ .946411374858402816D0/
6035       DATA XGAUSS(89)/ .961008799652053719D0/
6036       DATA XGAUSS(90)/ .973326827789910964D0/
6037       DATA XGAUSS(91)/ .983336253884625957D0/
6038       DATA XGAUSS(92)/ .991013371476744321D0/
6039       DATA XGAUSS(93)/ .996340116771955279D0/
6040       DATA XGAUSS(94)/ .999305041735772139D0/
6041       DATA XGAUSS(95)/-.02435029266342443250D0/
6042       DATA XGAUSS(96)/-.0729931217877990394D0/
6043       DATA XGAUSS(97)/-.121462819296120554D0/
6044       DATA XGAUSS(98)/-.169644420423992818D0/
6045       DATA XGAUSS(99)/-.217423643740007084D0/
6046       DATA XGAUSS(100)/-.264687162208767416D0/
6047       DATA XGAUSS(101)/-.311322871990210956D0/
6048       DATA XGAUSS(102)/-.357220158337668116D0/
6049       DATA XGAUSS(103)/-.402270157963991604D0/
6050       DATA XGAUSS(104)/-.446366017253464088D0/
6051       DATA XGAUSS(105)/-.489403145707052957D0/
6052       DATA XGAUSS(106)/-.531279464019894546D0/
6053       DATA XGAUSS(107)/-.571895646202634034D0/
6054       DATA XGAUSS(108)/-.611155355172393250D0/
6055       DATA XGAUSS(109)/-.648965471254657340D0/
6056       DATA XGAUSS(110)/-.685236313054233243D0/
6057       DATA XGAUSS(111)/-.719881850171610827D0/
6058       DATA XGAUSS(112)/-.752819907260531897D0/
6059       DATA XGAUSS(113)/-.783972358943341408D0/
6060       DATA XGAUSS(114)/-.813265315122797560D0/
6061       DATA XGAUSS(115)/-.840629296252580363D0/
6062       DATA XGAUSS(116)/-.865999398154092820D0/
6063       DATA XGAUSS(117)/-.889315445995114106D0/
6064       DATA XGAUSS(118)/-.910522137078502806D0/
6065       DATA XGAUSS(119)/-.929569172131939576D0/
6066       DATA XGAUSS(120)/-.946411374858402816D0/
6067       DATA XGAUSS(121)/-.961008799652053719D0/
6068       DATA XGAUSS(122)/-.973326827789910964D0/
6069       DATA XGAUSS(123)/-.983336253884625957D0/
6070       DATA XGAUSS(124)/-.991013371476744321D0/
6071       DATA XGAUSS(125)/-.996340116771955279D0/
6072       DATA XGAUSS(126)/-.999305041735772139D0/
6073       DATA WGAUSS(63)/ .0486909570091397204D0/
6074       DATA WGAUSS(64)/ .0485754674415034269D0/
6075       DATA WGAUSS(65)/ .0483447622348029572D0/
6076       DATA WGAUSS(66)/ .0479993885964583077D0/
6077       DATA WGAUSS(67)/ .0475401657148303087D0/
6078       DATA WGAUSS(68)/ .0469681828162100173D0/
6079       DATA WGAUSS(69)/ .0462847965813144172D0/
6080       DATA WGAUSS(70)/ .0454916279274181445D0/
6081       DATA WGAUSS(71)/ .0445905581637565631D0/
6082       DATA WGAUSS(72)/ .0435837245293234534D0/
6083       DATA WGAUSS(73)/ .0424735151236535890D0/
6084       DATA WGAUSS(74)/ .0412625632426235286D0/
6085       DATA WGAUSS(75)/ .0399537411327203414D0/
6086       DATA WGAUSS(76)/ .0385501531786156291D0/
6087       DATA WGAUSS(77)/ .0370551285402400460D0/
6088       DATA WGAUSS(78)/ .0354722132568823838D0/
6089       DATA WGAUSS(79)/ .0338051618371416094D0/
6090       DATA WGAUSS(80)/ .0320579283548515535D0/
6091       DATA WGAUSS(81)/ .0302346570724024789D0/
6092       DATA WGAUSS(82)/ .0283396726142594832D0/
6093       DATA WGAUSS(83)/ .0263774697150546587D0/
6094       DATA WGAUSS(84)/ .0243527025687108733D0/
6095       DATA WGAUSS(85)/ .0222701738083832542D0/
6096       DATA WGAUSS(86)/ .0201348231535302094D0/
6097       DATA WGAUSS(87)/ .0179517157756973431D0/
6098       DATA WGAUSS(88)/ .0157260304760247193D0/
6099       DATA WGAUSS(89)/ .0134630478967186426D0/
6100       DATA WGAUSS(90)/ .0111681394601311288D0/
6101       DATA WGAUSS(91)/ .00884675982636394772D0/
6102       DATA WGAUSS(92)/ .00650445796897836286D0/
6103       DATA WGAUSS(93)/ .00414703326056246764D0/
6104       DATA WGAUSS(94)/ .00178328072169643295D0/
6105       DATA WGAUSS(95)/ .0486909570091397204D0/
6106       DATA WGAUSS(96)/ .0485754674415034269D0/
6107       DATA WGAUSS(97)/ .0483447622348029572D0/
6108       DATA WGAUSS(98)/ .0479993885964583077D0/
6109       DATA WGAUSS(99)/ .0475401657148303087D0/
6110       DATA WGAUSS(100)/ .0469681828162100173D0/
6111       DATA WGAUSS(101)/ .0462847965813144172D0/
6112       DATA WGAUSS(102)/ .0454916279274181445D0/
6113       DATA WGAUSS(103)/ .0445905581637565631D0/
6114       DATA WGAUSS(104)/ .0435837245293234534D0/
6115       DATA WGAUSS(105)/ .0424735151236535890D0/
6116       DATA WGAUSS(106)/ .0412625632426235286D0/
6117       DATA WGAUSS(107)/ .0399537411327203414D0/
6118       DATA WGAUSS(108)/ .0385501531786156291D0/
6119       DATA WGAUSS(109)/ .0370551285402400460D0/
6120       DATA WGAUSS(110)/ .0354722132568823838D0/
6121       DATA WGAUSS(111)/ .0338051618371416094D0/
6122       DATA WGAUSS(112)/ .0320579283548515535D0/
6123       DATA WGAUSS(113)/ .0302346570724024789D0/
6124       DATA WGAUSS(114)/ .0283396726142594832D0/
6125       DATA WGAUSS(115)/ .0263774697150546587D0/
6126       DATA WGAUSS(116)/ .0243527025687108733D0/
6127       DATA WGAUSS(117)/ .0222701738083832542D0/
6128       DATA WGAUSS(118)/ .0201348231535302094D0/
6129       DATA WGAUSS(119)/ .0179517157756973431D0/
6130       DATA WGAUSS(120)/ .0157260304760247193D0/
6131       DATA WGAUSS(121)/ .0134630478967186426D0/
6132       DATA WGAUSS(122)/ .0111681394601311288D0/
6133       DATA WGAUSS(123)/ .00884675982636394772D0/
6134       DATA WGAUSS(124)/ .00650445796897836286D0/
6135       DATA WGAUSS(125)/ .00414703326056246764D0/
6136       DATA WGAUSS(126)/ .00178328072169643295D0/
6137
6138 C integrate first over b1
6139 C
6140 C Loop incrementing the boundary
6141 C
6142       tmin = 0.D0
6143       tmax = 0.25D0
6144       Sum  = 0.D0
6145
6146  50   CONTINUE
6147
6148 C
6149 C Loop for the Gauss integration
6150 C
6151       XINT=0.D0
6152       DO 100 N=1,6
6153         XINT2 = XINT
6154         XINT=0.D0
6155         DO 200 I=2**N-1,2**(N+1)-2
6156           t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
6157           b1 = RADSRC(1) * EXP (t)
6158           XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
6159  200    CONTINUE
6160         XINT = (tmax-tmin)/2.D0*XINT
6161         IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
6162  100  CONTINUE
6163         WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
6164  300  CONTINUE
6165
6166       Sum = Sum + XINT
6167       IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
6168         tmin = tmax
6169         tmax = tmax + 0.5D0
6170         GOTO 50
6171       ENDIF
6172
6173       PHO_GGFLCR = 4.D0*Pi * Sum
6174
6175       END
6176
6177 *$ CREATE PHO_GGFAUX.FOR
6178 *COPY PHO_GGFAUX
6179 CDECK  ID>, PHO_GGFAUX
6180       DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
6181 C*********************************************************************
6182 C
6183 C     auxiliary function for integration over b2,
6184 C     semi-classical photon flux correction due to
6185 C     overlap in impact parameter space (geometrical model)
6186 C
6187 C*********************************************************************
6188       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6189       SAVE
6190
6191       PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
6192
6193 C  input/output channels
6194       INTEGER LI,LO
6195       COMMON /POINOU/ LI,LO
6196 C  gamma-lepton or gamma-hadron vertex information
6197       INTEGER IGHEL,IDPSRC,IDBSRC
6198       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6199      &                 RADSRC,AMSRC,GAMSRC
6200       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6201      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6202      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6203
6204       DIMENSION XGAUSS(126),WGAUSS(126)
6205
6206       DATA XGAUSS(1)/ .57735026918962576D0/
6207       DATA XGAUSS(2)/-.57735026918962576D0/
6208       DATA WGAUSS(1)/ 1.00000000000000000D0/
6209       DATA WGAUSS(2)/ 1.00000000000000000D0/
6210
6211       DATA XGAUSS(3)/ .33998104358485627D0/
6212       DATA XGAUSS(4)/ .86113631159405258D0/
6213       DATA XGAUSS(5)/-.33998104358485627D0/
6214       DATA XGAUSS(6)/-.86113631159405258D0/
6215       DATA WGAUSS(3)/ .65214515486254613D0/
6216       DATA WGAUSS(4)/ .34785484513745385D0/
6217       DATA WGAUSS(5)/ .65214515486254613D0/
6218       DATA WGAUSS(6)/ .34785484513745385D0/
6219
6220       DATA XGAUSS(7)/ .18343464249564981D0/
6221       DATA XGAUSS(8)/ .52553240991632899D0/
6222       DATA XGAUSS(9)/ .79666647741362674D0/
6223       DATA XGAUSS(10)/ .96028985649753623D0/
6224       DATA XGAUSS(11)/-.18343464249564981D0/
6225       DATA XGAUSS(12)/-.52553240991632899D0/
6226       DATA XGAUSS(13)/-.79666647741362674D0/
6227       DATA XGAUSS(14)/-.96028985649753623D0/
6228       DATA WGAUSS(7)/ .36268378337836198D0/
6229       DATA WGAUSS(8)/ .31370664587788727D0/
6230       DATA WGAUSS(9)/ .22238103445337448D0/
6231       DATA WGAUSS(10)/ .10122853629037627D0/
6232       DATA WGAUSS(11)/ .36268378337836198D0/
6233       DATA WGAUSS(12)/ .31370664587788727D0/
6234       DATA WGAUSS(13)/ .22238103445337448D0/
6235       DATA WGAUSS(14)/ .10122853629037627D0/
6236
6237       DATA XGAUSS(15)/ .0950125098376374402D0/
6238       DATA XGAUSS(16)/ .281603550779258913D0/
6239       DATA XGAUSS(17)/ .458016777657227386D0/
6240       DATA XGAUSS(18)/ .617876244402643748D0/
6241       DATA XGAUSS(19)/ .755404408355003034D0/
6242       DATA XGAUSS(20)/ .865631202387831744D0/
6243       DATA XGAUSS(21)/ .944575023073232576D0/
6244       DATA XGAUSS(22)/ .989400934991649933D0/
6245       DATA XGAUSS(23)/-.0950125098376374402D0/
6246       DATA XGAUSS(24)/-.281603550779258913D0/
6247       DATA XGAUSS(25)/-.458016777657227386D0/
6248       DATA XGAUSS(26)/-.617876244402643748D0/
6249       DATA XGAUSS(27)/-.755404408355003034D0/
6250       DATA XGAUSS(28)/-.865631202387831744D0/
6251       DATA XGAUSS(29)/-.944575023073232576D0/
6252       DATA XGAUSS(30)/-.989400934991649933D0/
6253       DATA WGAUSS(15)/ .189450610455068496D0/
6254       DATA WGAUSS(16)/ .182603415044923589D0/
6255       DATA WGAUSS(17)/ .169156519395002538D0/
6256       DATA WGAUSS(18)/ .149595988816576732D0/
6257       DATA WGAUSS(19)/ .124628971255533872D0/
6258       DATA WGAUSS(20)/ .0951585116824927848D0/
6259       DATA WGAUSS(21)/ .0622535239386478929D0/
6260       DATA WGAUSS(22)/ .0271524594117540949D0/
6261       DATA WGAUSS(23)/ .189450610455068496D0/
6262       DATA WGAUSS(24)/ .182603415044923589D0/
6263       DATA WGAUSS(25)/ .169156519395002538D0/
6264       DATA WGAUSS(26)/ .149595988816576732D0/
6265       DATA WGAUSS(27)/ .124628971255533872D0/
6266       DATA WGAUSS(28)/ .0951585116824927848D0/
6267       DATA WGAUSS(29)/ .0622535239386478929D0/
6268       DATA WGAUSS(30)/ .0271524594117540949D0/
6269
6270       DATA XGAUSS(31)/ .0483076656877383162D0/
6271       DATA XGAUSS(32)/ .144471961582796493D0/
6272       DATA XGAUSS(33)/ .239287362252137075D0/
6273       DATA XGAUSS(34)/ .331868602282127650D0/
6274       DATA XGAUSS(35)/ .421351276130635345D0/
6275       DATA XGAUSS(36)/ .506899908932229390D0/
6276       DATA XGAUSS(37)/ .587715757240762329D0/
6277       DATA XGAUSS(38)/ .663044266930215201D0/
6278       DATA XGAUSS(39)/ .732182118740289680D0/
6279       DATA XGAUSS(40)/ .794483795967942407D0/
6280       DATA XGAUSS(41)/ .849367613732569970D0/
6281       DATA XGAUSS(42)/ .896321155766052124D0/
6282       DATA XGAUSS(43)/ .934906075937739689D0/
6283       DATA XGAUSS(44)/ .964762255587506430D0/
6284       DATA XGAUSS(45)/ .985611511545268335D0/
6285       DATA XGAUSS(46)/ .997263861849481564D0/
6286       DATA XGAUSS(47)/-.0483076656877383162D0/
6287       DATA XGAUSS(48)/-.144471961582796493D0/
6288       DATA XGAUSS(49)/-.239287362252137075D0/
6289       DATA XGAUSS(50)/-.331868602282127650D0/
6290       DATA XGAUSS(51)/-.421351276130635345D0/
6291       DATA XGAUSS(52)/-.506899908932229390D0/
6292       DATA XGAUSS(53)/-.587715757240762329D0/
6293       DATA XGAUSS(54)/-.663044266930215201D0/
6294       DATA XGAUSS(55)/-.732182118740289680D0/
6295       DATA XGAUSS(56)/-.794483795967942407D0/
6296       DATA XGAUSS(57)/-.849367613732569970D0/
6297       DATA XGAUSS(58)/-.896321155766052124D0/
6298       DATA XGAUSS(59)/-.934906075937739689D0/
6299       DATA XGAUSS(60)/-.964762255587506430D0/
6300       DATA XGAUSS(61)/-.985611511545268335D0/
6301       DATA XGAUSS(62)/-.997263861849481564D0/
6302       DATA WGAUSS(31)/ .0965400885147278006D0/
6303       DATA WGAUSS(32)/ .0956387200792748594D0/
6304       DATA WGAUSS(33)/ .0938443990808045654D0/
6305       DATA WGAUSS(34)/ .0911738786957638847D0/
6306       DATA WGAUSS(35)/ .0876520930044038111D0/
6307       DATA WGAUSS(36)/ .0833119242269467552D0/
6308       DATA WGAUSS(37)/ .0781938957870703065D0/
6309       DATA WGAUSS(38)/ .0723457941088485062D0/
6310       DATA WGAUSS(39)/ .0658222227763618468D0/
6311       DATA WGAUSS(40)/ .0586840934785355471D0/
6312       DATA WGAUSS(41)/ .0509980592623761762D0/
6313       DATA WGAUSS(42)/ .0428358980222266807D0/
6314       DATA WGAUSS(43)/ .0342738629130214331D0/
6315       DATA WGAUSS(44)/ .0253920653092620595D0/
6316       DATA WGAUSS(45)/ .0162743947309056706D0/
6317       DATA WGAUSS(46)/ .00701861000947009660D0/
6318       DATA WGAUSS(47)/ .0965400885147278006D0/
6319       DATA WGAUSS(48)/ .0956387200792748594D0/
6320       DATA WGAUSS(49)/ .0938443990808045654D0/
6321       DATA WGAUSS(50)/ .0911738786957638847D0/
6322       DATA WGAUSS(51)/ .0876520930044038111D0/
6323       DATA WGAUSS(52)/ .0833119242269467552D0/
6324       DATA WGAUSS(53)/ .0781938957870703065D0/
6325       DATA WGAUSS(54)/ .0723457941088485062D0/
6326       DATA WGAUSS(55)/ .0658222227763618468D0/
6327       DATA WGAUSS(56)/ .0586840934785355471D0/
6328       DATA WGAUSS(57)/ .0509980592623761762D0/
6329       DATA WGAUSS(58)/ .0428358980222266807D0/
6330       DATA WGAUSS(59)/ .0342738629130214331D0/
6331       DATA WGAUSS(60)/ .0253920653092620595D0/
6332       DATA WGAUSS(61)/ .0162743947309056706D0/
6333       DATA WGAUSS(62)/ .00701861000947009660D0/
6334
6335       DATA XGAUSS(63)/ .02435029266342443250D0/
6336       DATA XGAUSS(64)/ .0729931217877990394D0/
6337       DATA XGAUSS(65)/ .121462819296120554D0/
6338       DATA XGAUSS(66)/ .169644420423992818D0/
6339       DATA XGAUSS(67)/ .217423643740007084D0/
6340       DATA XGAUSS(68)/ .264687162208767416D0/
6341       DATA XGAUSS(69)/ .311322871990210956D0/
6342       DATA XGAUSS(70)/ .357220158337668116D0/
6343       DATA XGAUSS(71)/ .402270157963991604D0/
6344       DATA XGAUSS(72)/ .446366017253464088D0/
6345       DATA XGAUSS(73)/ .489403145707052957D0/
6346       DATA XGAUSS(74)/ .531279464019894546D0/
6347       DATA XGAUSS(75)/ .571895646202634034D0/
6348       DATA XGAUSS(76)/ .611155355172393250D0/
6349       DATA XGAUSS(77)/ .648965471254657340D0/
6350       DATA XGAUSS(78)/ .685236313054233243D0/
6351       DATA XGAUSS(79)/ .719881850171610827D0/
6352       DATA XGAUSS(80)/ .752819907260531897D0/
6353       DATA XGAUSS(81)/ .783972358943341408D0/
6354       DATA XGAUSS(82)/ .813265315122797560D0/
6355       DATA XGAUSS(83)/ .840629296252580363D0/
6356       DATA XGAUSS(84)/ .865999398154092820D0/
6357       DATA XGAUSS(85)/ .889315445995114106D0/
6358       DATA XGAUSS(86)/ .910522137078502806D0/
6359       DATA XGAUSS(87)/ .929569172131939576D0/
6360       DATA XGAUSS(88)/ .946411374858402816D0/
6361       DATA XGAUSS(89)/ .961008799652053719D0/
6362       DATA XGAUSS(90)/ .973326827789910964D0/
6363       DATA XGAUSS(91)/ .983336253884625957D0/
6364       DATA XGAUSS(92)/ .991013371476744321D0/
6365       DATA XGAUSS(93)/ .996340116771955279D0/
6366       DATA XGAUSS(94)/ .999305041735772139D0/
6367       DATA XGAUSS(95)/-.02435029266342443250D0/
6368       DATA XGAUSS(96)/-.0729931217877990394D0/
6369       DATA XGAUSS(97)/-.121462819296120554D0/
6370       DATA XGAUSS(98)/-.169644420423992818D0/
6371       DATA XGAUSS(99)/-.217423643740007084D0/
6372       DATA XGAUSS(100)/-.264687162208767416D0/
6373       DATA XGAUSS(101)/-.311322871990210956D0/
6374       DATA XGAUSS(102)/-.357220158337668116D0/
6375       DATA XGAUSS(103)/-.402270157963991604D0/
6376       DATA XGAUSS(104)/-.446366017253464088D0/
6377       DATA XGAUSS(105)/-.489403145707052957D0/
6378       DATA XGAUSS(106)/-.531279464019894546D0/
6379       DATA XGAUSS(107)/-.571895646202634034D0/
6380       DATA XGAUSS(108)/-.611155355172393250D0/
6381       DATA XGAUSS(109)/-.648965471254657340D0/
6382       DATA XGAUSS(110)/-.685236313054233243D0/
6383       DATA XGAUSS(111)/-.719881850171610827D0/
6384       DATA XGAUSS(112)/-.752819907260531897D0/
6385       DATA XGAUSS(113)/-.783972358943341408D0/
6386       DATA XGAUSS(114)/-.813265315122797560D0/
6387       DATA XGAUSS(115)/-.840629296252580363D0/
6388       DATA XGAUSS(116)/-.865999398154092820D0/
6389       DATA XGAUSS(117)/-.889315445995114106D0/
6390       DATA XGAUSS(118)/-.910522137078502806D0/
6391       DATA XGAUSS(119)/-.929569172131939576D0/
6392       DATA XGAUSS(120)/-.946411374858402816D0/
6393       DATA XGAUSS(121)/-.961008799652053719D0/
6394       DATA XGAUSS(122)/-.973326827789910964D0/
6395       DATA XGAUSS(123)/-.983336253884625957D0/
6396       DATA XGAUSS(124)/-.991013371476744321D0/
6397       DATA XGAUSS(125)/-.996340116771955279D0/
6398       DATA XGAUSS(126)/-.999305041735772139D0/
6399       DATA WGAUSS(63)/ .0486909570091397204D0/
6400       DATA WGAUSS(64)/ .0485754674415034269D0/
6401       DATA WGAUSS(65)/ .0483447622348029572D0/
6402       DATA WGAUSS(66)/ .0479993885964583077D0/
6403       DATA WGAUSS(67)/ .0475401657148303087D0/
6404       DATA WGAUSS(68)/ .0469681828162100173D0/
6405       DATA WGAUSS(69)/ .0462847965813144172D0/
6406       DATA WGAUSS(70)/ .0454916279274181445D0/
6407       DATA WGAUSS(71)/ .0445905581637565631D0/
6408       DATA WGAUSS(72)/ .0435837245293234534D0/
6409       DATA WGAUSS(73)/ .0424735151236535890D0/
6410       DATA WGAUSS(74)/ .0412625632426235286D0/
6411       DATA WGAUSS(75)/ .0399537411327203414D0/
6412       DATA WGAUSS(76)/ .0385501531786156291D0/
6413       DATA WGAUSS(77)/ .0370551285402400460D0/
6414       DATA WGAUSS(78)/ .0354722132568823838D0/
6415       DATA WGAUSS(79)/ .0338051618371416094D0/
6416       DATA WGAUSS(80)/ .0320579283548515535D0/
6417       DATA WGAUSS(81)/ .0302346570724024789D0/
6418       DATA WGAUSS(82)/ .0283396726142594832D0/
6419       DATA WGAUSS(83)/ .0263774697150546587D0/
6420       DATA WGAUSS(84)/ .0243527025687108733D0/
6421       DATA WGAUSS(85)/ .0222701738083832542D0/
6422       DATA WGAUSS(86)/ .0201348231535302094D0/
6423       DATA WGAUSS(87)/ .0179517157756973431D0/
6424       DATA WGAUSS(88)/ .0157260304760247193D0/
6425       DATA WGAUSS(89)/ .0134630478967186426D0/
6426       DATA WGAUSS(90)/ .0111681394601311288D0/
6427       DATA WGAUSS(91)/ .00884675982636394772D0/
6428       DATA WGAUSS(92)/ .00650445796897836286D0/
6429       DATA WGAUSS(93)/ .00414703326056246764D0/
6430       DATA WGAUSS(94)/ .00178328072169643295D0/
6431       DATA WGAUSS(95)/ .0486909570091397204D0/
6432       DATA WGAUSS(96)/ .0485754674415034269D0/
6433       DATA WGAUSS(97)/ .0483447622348029572D0/
6434       DATA WGAUSS(98)/ .0479993885964583077D0/
6435       DATA WGAUSS(99)/ .0475401657148303087D0/
6436       DATA WGAUSS(100)/ .0469681828162100173D0/
6437       DATA WGAUSS(101)/ .0462847965813144172D0/
6438       DATA WGAUSS(102)/ .0454916279274181445D0/
6439       DATA WGAUSS(103)/ .0445905581637565631D0/
6440       DATA WGAUSS(104)/ .0435837245293234534D0/
6441       DATA WGAUSS(105)/ .0424735151236535890D0/
6442       DATA WGAUSS(106)/ .0412625632426235286D0/
6443       DATA WGAUSS(107)/ .0399537411327203414D0/
6444       DATA WGAUSS(108)/ .0385501531786156291D0/
6445       DATA WGAUSS(109)/ .0370551285402400460D0/
6446       DATA WGAUSS(110)/ .0354722132568823838D0/
6447       DATA WGAUSS(111)/ .0338051618371416094D0/
6448       DATA WGAUSS(112)/ .0320579283548515535D0/
6449       DATA WGAUSS(113)/ .0302346570724024789D0/
6450       DATA WGAUSS(114)/ .0283396726142594832D0/
6451       DATA WGAUSS(115)/ .0263774697150546587D0/
6452       DATA WGAUSS(116)/ .0243527025687108733D0/
6453       DATA WGAUSS(117)/ .0222701738083832542D0/
6454       DATA WGAUSS(118)/ .0201348231535302094D0/
6455       DATA WGAUSS(119)/ .0179517157756973431D0/
6456       DATA WGAUSS(120)/ .0157260304760247193D0/
6457       DATA WGAUSS(121)/ .0134630478967186426D0/
6458       DATA WGAUSS(122)/ .0111681394601311288D0/
6459       DATA WGAUSS(123)/ .00884675982636394772D0/
6460       DATA WGAUSS(124)/ .00650445796897836286D0/
6461       DATA WGAUSS(125)/ .00414703326056246764D0/
6462       DATA WGAUSS(126)/ .00178328072169643295D0/
6463 C
6464       W1 = PGAM(4,1)
6465       W2 = PGAM(4,2)
6466       bmin = b1 - 2.D0*RADSRC(1)
6467       IF (RADSRC(1) .GT. bmin) THEN
6468         bmin = RADSRC(1)
6469       ENDIF
6470       bmax = b1 + 2.D0 * RADSRC(1)
6471
6472       XINT = 0.D0
6473       DO 100 N=1,6
6474         XINT2 = XINT
6475         XINT = 0.D0
6476         DO 200 I=2**N-1,2**(N+1)-2
6477           b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
6478           XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
6479      &      * PHO_GGFNUC(W2,b2,GAMSRC(2))
6480      &      * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
6481           XINT = XINT +WGAUSS(I) * b2 * XINT3
6482  200    CONTINUE
6483         XINT = (bmax-bmin)/2.D0*XINT
6484         IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
6485  100  CONTINUE
6486       WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
6487  300  CONTINUE
6488
6489       PHO_GGFAUX = XINT
6490
6491       END
6492
6493 *$ CREATE PHO_GGFNUC.FOR
6494 *COPY PHO_GGFNUC
6495 CDECK  ID>, PHO_GGFNUC
6496       DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
6497 C**********************************************************************
6498 C
6499 C      differential photonnumber for a nucleus (geometrical model)
6500 C      (without form factor)
6501 C
6502 C*********************************************************************
6503       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6504       SAVE
6505
6506       PARAMETER (PI = 3.14159265359D0)
6507
6508       WGamma = W/Gamma
6509       Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
6510
6511       PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
6512
6513       END
6514
6515 *$ CREATE PHO_GHHIOF.FOR
6516 *COPY PHO_GHHIOF
6517 CDECK  ID>, PHO_GHHIOF
6518       SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
6519 C**********************************************************************
6520 C
6521 C     interface to call PHOJET (variable energy run) for
6522 C     gamma-hadron collisions in heavy ion collisions
6523 C     (form factor approach)
6524 C
6525 C     input:     EEN     LAB system energy per nucleon
6526 C                NA      atomic number of ion/hadron
6527 C                NZ      charge number of ion/hadron
6528 C                NEVENT  number of events to generate
6529 C            from /LEPCUT/:
6530 C                YMIN1,2 lower limit of Y
6531 C                        (energy fraction taken by photon from hadron)
6532 C                YMAX1,2 upper cutoff for Y, necessary to avoid
6533 C                        underflows
6534 C                Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
6535 C                Q2MAX1,2 maximum Q**2 of photons (if necessary,
6536 C                        corrected according size of hadron)
6537 C
6538 C**********************************************************************
6539       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6540       SAVE
6541
6542       PARAMETER ( PI   = 3.14159265359D0 )
6543
6544 C  input/output channels
6545       INTEGER LI,LO
6546       COMMON /POINOU/ LI,LO
6547 C  model switches and parameters
6548       CHARACTER*8 MDLNA
6549       INTEGER ISWMDL,IPAMDL
6550       DOUBLE PRECISION PARMDL
6551       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
6552 C  event debugging information
6553       INTEGER NMAXD
6554       PARAMETER (NMAXD=100)
6555       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
6556      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6557       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
6558      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6559 C  photon flux kinematics and cuts
6560       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
6561      &                 YMIN1,YMAX1,YMIN2,YMAX2,
6562      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6563      &                 THMIN1,THMAX1,THMIN2,THMAX2
6564       INTEGER          ITAG1,ITAG2
6565       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
6566      &                YMIN1,YMAX1,YMIN2,YMAX2,
6567      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6568      &                THMIN1,THMAX1,THMIN2,THMAX2,
6569      &                ITAG1,ITAG2
6570 C  gamma-lepton or gamma-hadron vertex information
6571       INTEGER IGHEL,IDPSRC,IDBSRC
6572       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6573      &                 RADSRC,AMSRC,GAMSRC
6574       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6575      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6576      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6577 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
6578       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
6579       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
6580       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
6581      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
6582
6583 C  standard particle data interface
6584       INTEGER NMXHEP
6585
6586       PARAMETER (NMXHEP=4000)
6587
6588       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
6589       DOUBLE PRECISION PHEP,VHEP
6590       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
6591      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
6592      &                VHEP(4,NMXHEP)
6593 C  extension to standard particle data interface (PHOJET specific)
6594       INTEGER IMPART,IPHIST,ICOLOR
6595       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
6596
6597 C  event weights and generated cross section
6598       INTEGER IPOWGC,ISWCUT,IVWGHT
6599       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
6600       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
6601      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
6602
6603       DIMENSION P1(4),P2(4)
6604       DIMENSION NITERS(2),ITRW(2)
6605
6606       WRITE(LO,'(2(/1X,A))')
6607      &  'PHO_GHHIOF: gamma-hadron event generation',
6608      &  '-----------------------------------------'
6609 C  hadron size and mass
6610       FM2GEV = 5.07D0
6611       HIMASS = DBLE(NA)*0.938D0
6612       HIMA2  = HIMASS**2
6613       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
6614       ALPHA  = DBLE(NZ**2)/137.D0
6615       AMP  = 0.938D0
6616       AMP2 = AMP**2
6617 C  correct Q2MAX1,2 according to hadron size
6618       Q2MAXH = 2.D0/HIRADI**2
6619       Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
6620       Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
6621       IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
6622       IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
6623 C  total hadron / heavy ion energy
6624       EE = EEN*DBLE(NA)
6625       GAMMA = EE/HIMASS
6626 C  setup /POFSRC/
6627       GAMSRC(1) = GAMMA
6628       GAMSRC(2) = GAMMA
6629       RADSRC(1) = HIRADI
6630       RADSRC(2) = HIRADI
6631       AMSRC(1)  = HIMASS
6632       AMSRC(2)  = HIMASS
6633 C  check cuts on photon-hadron mass
6634       IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
6635         YMI = ECMIN
6636         ECMIN =  PARMDL(46)/PARMDL(45)+0.1D0
6637         WRITE(LO,'(/1X,A,2E12.5)')
6638      &    'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
6639       ENDIF
6640 C  check kinematic limitations
6641       YMI = ECMIN**2/(4.D0*EE*EEN)
6642       IF(YMIN1.LT.YMI) THEN
6643         WRITE(LO,'(/1X,A,2E12.5)')
6644      &    'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
6645         YMIN1 = YMI
6646       ELSE IF(YMIN1.GT.YMI) THEN
6647         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6648      &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
6649      &    '  INSTEAD OF',YMIN1
6650       ENDIF
6651       IF(YMIN2.LT.YMI) THEN
6652         WRITE(LO,'(/1X,A,2E12.5)')
6653      &    'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
6654         YMIN2 = YMI
6655       ELSE IF(YMIN2.GT.YMI) THEN
6656         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6657      &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
6658      &    '  INSTEAD OF',YMIN2
6659       ENDIF
6660 C  kinematic limitation
6661       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6662       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6663 C  debug output
6664       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
6665       WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
6666       WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
6667       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
6668      &  Q2MAX1
6669       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
6670      &  Q2MAX2
6671       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
6672      &  YMAX1
6673       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
6674      &  YMAX2
6675       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
6676      &  2.D0*EEN,2.D0*EE
6677       WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON      ',ECMIN,
6678      &  ECMAX
6679       WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
6680      &  PARMDL(175)
6681       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
6682       IF(Q2LOW1.GE.Q2MAX1) THEN
6683         WRITE(LO,'(/1X,A,2E12.4)')
6684      &    'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
6685         CALL PHO_ABORT
6686       ENDIF
6687       IF(Q2LOW2.GE.Q2MAX2) THEN
6688         WRITE(LO,'(/1X,A,2E12.4)')
6689      &    'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
6690         CALL PHO_ABORT
6691       ENDIF
6692 C  hadron numbers set to 0
6693       IDPSRC(1) = 0
6694       IDPSRC(2) = 0
6695       IDBSRC(1) = 0
6696       IDBSRC(2) = 0
6697 C
6698       Max_tab = 100
6699       YMAX = YMAX1
6700       YMIN = YMIN1
6701       XMAX = LOG(YMAX)
6702       XMIN = LOG(YMIN)
6703       XDEL = XMAX-XMIN
6704       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6705       DO 100 I=1,Max_tab
6706         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6707         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6708         IF(Q2LOW1.GE.Q2MAX1) THEN
6709           WRITE(LO,'(/1X,A,2E12.4)')
6710      &      'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
6711           YMAX1 = MIN(Y1,YMAX1)
6712           GOTO 101
6713         ENDIF
6714  100  CONTINUE
6715  101  CONTINUE
6716       YMAX = YMAX2
6717       YMIN = YMIN2
6718       XMAX = LOG(YMAX)
6719       XMIN = LOG(YMIN)
6720       XDEL = XMAX-XMIN
6721       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6722       DO 102 I=1,Max_tab
6723         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6724         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
6725         IF(Q2LOW2.GE.Q2MAX2) THEN
6726           WRITE(LO,'(/1X,A,2E12.4)')
6727      &      'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
6728           YMAX2 = MIN(Y1,YMAX2)
6729           GOTO 103
6730         ENDIF
6731  102  CONTINUE
6732  103  CONTINUE
6733 C
6734       X1MAX = LOG(YMAX1)
6735       X1MIN = LOG(YMIN1)
6736       X1DEL = X1MAX-X1MIN
6737       X2MAX = LOG(YMAX2)
6738       X2MIN = LOG(YMIN2)
6739       X2DEL = X2MAX-X2MIN
6740       DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
6741       FLUX = 0.D0
6742       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
6743      &  'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
6744       DO 105 I=1,Max_tab
6745         Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
6746         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6747         FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
6748      &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
6749         FLUX = FLUX+Y1*FF
6750         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
6751  105  CONTINUE
6752       FLUX = FLUX*DELLY
6753       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
6754      &  'PHO_GHHIOF: integrated flux (one side):',FLUX
6755 C
6756 C  photon
6757       EGAM = MAX(YMAX1,YMAX2)*EE
6758       P1(1) = 0.D0
6759       P1(2) = 0.D0
6760       P1(3) = EGAM
6761       P1(4) = EGAM
6762 C  hadron
6763       P2(1) = 0.D0
6764       P2(2) = 0.D0
6765       P2(3) = -SQRT(EEN**2-AMP2)
6766       P2(4) = EEN
6767       CALL PHO_SETPAR(1,22,0,0.D0)
6768       CALL PHO_SETPAR(2,2212,0,0.D0)
6769       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
6770 C
6771       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6772       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6773       Y1 = YMIN1
6774       Y2 = YMIN2
6775       WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
6776      &         -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6777       WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
6778      &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6779 C
6780       IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
6781       IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
6782 C
6783       FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
6784      &       /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
6785 C
6786       CALL PHO_PHIST(-1,SIGMAX)
6787       CALL PHO_LHIST(-1,SIGMAX)
6788 C
6789 C  generation of events, flux calculation
6790
6791       AY1  = 0.D0
6792       AY2  = 0.D0
6793       AYS1 = 0.D0
6794       AYS2 = 0.D0
6795       Q21MIN = 1.D30
6796       Q22MIN = 1.D30
6797       Q21MAX = 0.D0
6798       Q22MAX = 0.D0
6799       Q21AVE = 0.D0
6800       Q22AVE = 0.D0
6801       Q21AV2 = 0.D0
6802       Q22AV2 = 0.D0
6803       YY1MIN = 1.D30
6804       YY2MIN = 1.D30
6805       YY1MAX = 0.D0
6806       YY2MAX = 0.D0
6807       NITER = NEVENT
6808       NITERS(1) = 0
6809       NITERS(2) = 0
6810       ITRY = 0
6811       ITRW(1) = 0
6812       ITRW(2) = 0
6813       DO 200 I=1,NITER
6814 C  sample y1, y2
6815  150    CONTINUE
6816         ITRY = ITRY+1
6817  175    CONTINUE
6818 C
6819 C  select side of photon emission
6820         IF(DT_RNDM(AY1).LT.FAC12) THEN
6821           ITRW(1) = ITRW(1)+1
6822 C  select Y1
6823           Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
6824           Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
6825           IF(Q2LOW1.GE.Q2MAX1) GOTO 175
6826           Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
6827           WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
6828      &          -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6829           IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6830      &        'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
6831           IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
6832 C  sample Q2
6833           IF(IPAMDL(174).EQ.1) THEN
6834             YEFF = 1.D0+(1.D0-Y1)**2
6835  185        CONTINUE
6836               Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
6837               WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
6838             IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
6839           ELSE
6840             Q2P1 = Q2LOW1
6841           ENDIF
6842 C  impact parameter
6843           GAIMP(1) = 1.D0/SQRT(Q2P1)
6844 C  form factor (squared)
6845           FF2 = 1.D0
6846           IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
6847           IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
6848 C  photon data
6849           GYY(1) = Y1
6850           GQ2(1) = Q2P1
6851
6852 C
6853 C  incoming hadron 1
6854           PINI(1,1) = 0.D0
6855           PINI(2,1) = 0.D0
6856           PINI(3,1) = SQRT(EE**2-AMP2)
6857           PINI(4,1) = EE
6858           PINI(5,1) = AMP
6859 C  outgoing hadron 1
6860           YQ2 = SQRT((1.D0-Y1)*Q2P1)
6861           Q2E = Q2P1/(4.D0*EE)
6862           E1Y = EE*(1.D0-Y1)
6863           CALL PHO_SFECFE(SIF,COF)
6864           PFIN(1,1) = YQ2*COF
6865           PFIN(2,1) = YQ2*SIF
6866           PFIN(3,1) = E1Y-Q2E
6867           PFIN(4,1) = E1Y+Q2E
6868           PFIN(5,1) = 0.D0
6869           PFPHI(1) = ATAN2(COF,SIF)
6870           PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
6871 C  incoming hadron 2
6872           PINI(1,2) = 0.D0
6873           PINI(2,2) = 0.D0
6874           PINI(3,2) = -SQRT(EE**2-AMP2)
6875           PINI(4,2) = EE
6876           PINI(5,2) = AMP
6877 C  scattering photon
6878           P1(1) = -PFIN(1,1)
6879           P1(2) = -PFIN(2,1)
6880           P1(3) = PINI(3,1)-PFIN(3,1)
6881           P1(4) = PINI(4,1)-PFIN(4,1)
6882 C  scattering hadron
6883           P2(1) = 0.D0
6884           P2(2) = 0.D0
6885           P2(3) = -SQRT(EEN**2-AMP2)
6886           P2(4) = EEN
6887           ISIDE = 1
6888 C
6889         ELSE
6890 C
6891           ITRW(2) = ITRW(2)+1
6892 C  select Y2
6893           Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
6894           Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
6895           IF(Q2LOW2.GE.Q2MAX2) GOTO 175
6896           Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
6897           WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
6898      &          -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6899           IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6900      &        'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
6901           IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
6902 C  sample Q2
6903           IF(IPAMDL(174).EQ.1) THEN
6904             YEFF = 1.D0+(1.D0-Y2)**2
6905  186        CONTINUE
6906               Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
6907               WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
6908             IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
6909           ELSE
6910             Q2P2 = Q2LOW2
6911           ENDIF
6912 C  impact parameter
6913           GAIMP(2) = 1.D0/SQRT(Q2P2)
6914 C  form factor (squared)
6915           FF2 = 1.D0
6916           IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
6917           IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
6918 C  photon data
6919           GYY(2) = Y2
6920           GQ2(2) = Q2P2
6921
6922 C
6923 C  incoming hadron 1
6924           PINI(1,1) = 0.D0
6925           PINI(2,1) = 0.D0
6926           PINI(3,1) = SQRT(EE**2-AMP2)
6927           PINI(4,1) = EE
6928           PINI(5,1) = AMP
6929 C  incoming hadron 2
6930           PINI(1,2) = 0.D0
6931           PINI(2,2) = 0.D0
6932           PINI(3,2) = -SQRT(EE**2-AMP2)
6933           PINI(4,2) = EE
6934           PINI(5,2) = AMP
6935 C  outgoing hadron 2
6936           YQ2 = SQRT((1.D0-Y2)*Q2P2)
6937           Q2E = Q2P2/(4.D0*EE)
6938           E1Y = EE*(1.D0-Y2)
6939           CALL PHO_SFECFE(SIF,COF)
6940           PFIN(1,2) = YQ2*COF
6941           PFIN(2,2) = YQ2*SIF
6942           PFIN(3,2) = -E1Y+Q2E
6943           PFIN(4,2) = E1Y+Q2E
6944           PFIN(5,2) = 0.D0
6945           PFPHI(2) = ATAN2(COF,SIF)
6946           PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
6947 C  scattering hadron
6948           P2(1) = 0.D0
6949           P2(2) = 0.D0
6950           P2(3) = SQRT(EEN**2-AMP2)
6951           P2(4) = EEN
6952 C  scattering photon
6953           P1(1) = -PFIN(1,2)
6954           P1(2) = -PFIN(2,2)
6955           P1(3) = PINI(3,2)-PFIN(3,2)
6956           P1(4) = PINI(4,2)-PFIN(4,2)
6957           ISIDE = 2
6958         ENDIF
6959 C  ECMS cut
6960         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
6961      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
6962         IF(GGECM.LT.0.1D0) GOTO 175
6963         GGECM = SQRT(GGECM)
6964         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
6965 C
6966         PGAM(1,1) = P1(1)
6967         PGAM(2,1) = P1(2)
6968         PGAM(3,1) = P1(3)
6969         PGAM(4,1) = P1(4)
6970         PGAM(5,1) = -SQRT(Q2P1)
6971         PGAM(1,2) = P2(1)
6972         PGAM(2,2) = P2(2)
6973         PGAM(3,2) = P2(3)
6974         PGAM(4,2) = P2(4)
6975         PGAM(5,2) = -SQRT(Q2P2)
6976         CALL PHO_PRESEL(5,IREJ)
6977 C  photon helicities
6978         IGHEL(1) = 1
6979         IGHEL(2) = 1
6980 C  user cuts
6981         IF(IREJ.NE.0) GOTO 175
6982 C  event generation
6983         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
6984         IF(IREJ.NE.0) GOTO 150
6985 C  cut on diffractive mass
6986         DO 250 K=1,NHEP
6987           IF(ISTHEP(K).EQ.30) THEN
6988             GHDIFF = PHEP(1,K)
6989             IF(GHDIFF.GE.PARMDL(175)) THEN
6990               GOTO 251
6991             ELSE
6992               GOTO 150
6993             ENDIF
6994           ENDIF
6995  250    CONTINUE
6996         WRITE(LO,'(/,1X,A)')
6997      &    'PHO_GHHIOF: no diffractive entry found'
6998           CALL PHO_PREVNT(-1)
6999         GOTO 150
7000  251    CONTINUE
7001 C  remove quasi-elastically scattered hadron
7002         DO 260 K=1,NHEP
7003           IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7004             XF = ABS(PHEP(3,K)/EEN)
7005             IF(XF.LT.PARMDL(72)) GOTO 150
7006 *           ISTHEP(K) = 2
7007             GOTO 261
7008           ENDIF
7009  260    CONTINUE
7010  261    CONTINUE
7011 C
7012 C  statistics
7013
7014         NITERS(ISIDE) = NITERS(ISIDE)+1
7015         IF(ISIDE.EQ.1) THEN
7016
7017           AY1  = AY1+Y1
7018           AYS1 = AYS1+Y1*Y1
7019           Q21AVE = Q21AVE+Q2P1
7020           Q21AV2 = Q21AV2+Q2P1*Q2P1
7021           Q21MIN = MIN(Q21MIN,Q2P1)
7022           Q21MAX = MAX(Q21MAX,Q2P1)
7023           YY1MIN = MIN(YY1MIN,Y1)
7024           YY1MAX = MAX(YY1MAX,Y1)
7025         ELSE
7026
7027           AY2  = AY2+Y2
7028           AYS2 = AYS2+Y2*Y2
7029           Q22AVE = Q22AVE+Q2P2
7030           Q22AV2 = Q22AV2+Q2P2*Q2P2
7031           Q22MIN = MIN(Q22MIN,Q2P2)
7032           Q22MAX = MAX(Q22MAX,Q2P2)
7033           YY2MIN = MIN(YY2MIN,Y2)
7034           YY2MAX = MAX(YY2MAX,Y2)
7035         ENDIF
7036 C  histograms
7037         CALL PHO_PHIST(1,HSWGHT(0))
7038         CALL PHO_LHIST(1,HSWGHT(0))
7039  200  CONTINUE
7040 C
7041       WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
7042       WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
7043       WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
7044       WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
7045       AY1  = AY1/DBLE(MAX(NITERS(1),1))
7046       AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
7047       DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
7048       AY2  = AY2/DBLE(MAX(NITERS(2),1))
7049       AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
7050       DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
7051       Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
7052       Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
7053       Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
7054       Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
7055       Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
7056       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
7057       WGMAX  = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
7058       WGY    = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
7059       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7060 C  output of statistics, histograms
7061       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7062      &'=========================================================',
7063      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
7064      &'========================================================='
7065       WRITE(LO,'(//1X,A,/3X,6I12)')
7066      &  'PHO_GHHIOF:SUMMARY:  NITER,   NITERS1/2,   ITRY,    ITRW1,2',
7067      &  NITER,NITERS,ITRY,ITRW
7068       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7069      &  WGY,WEIGHT
7070       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
7071      &  AY1,DAY1
7072       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
7073      &  AY2,DAY2
7074       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
7075      &  YY1MIN,YY1MAX
7076       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
7077      &  YY2MIN,YY2MAX
7078       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1      ',
7079      &  Q21AVE,Q21AV2
7080       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1    ',
7081      &  Q21MIN,Q21MAX
7082       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
7083      &  Q22AVE,Q22AV2
7084       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
7085      &  Q22MIN,Q22MAX
7086 C
7087       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7088       IF(NITER.GT.1) THEN
7089         CALL PHO_PHIST(-2,WEIGHT)
7090         CALL PHO_LHIST(-2,WEIGHT)
7091       ELSE
7092         WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
7093       ENDIF
7094
7095       END
7096
7097 *$ CREATE PHO_GHHIAS.FOR
7098 *COPY PHO_GHHIAS
7099 CDECK  ID>, PHO_GHHIAS
7100       SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
7101 C**********************************************************************
7102 C
7103 C     interface to call PHOJET (variable energy run) for
7104 C     gamma-hadron collisions in heavy ion - hadron
7105 C     collisions (form factor approach)
7106 C
7107 C     input:     EEP     LAB system energy of proton (GeV)
7108 C                EEN     LAB system energy per nucleon (GeV)
7109 C                NA      atomic number of ion/hadron
7110 C                NZ      charge number of ion/hadron
7111 C                NEVENT  number of events to generate
7112 C            from /LEPCUT/:
7113 C                YMIN2   lower limit of Y
7114 C                        (energy fraction taken by photon from hadron)
7115 C                YMAX2   upper cutoff for Y, necessary to avoid
7116 C                        underflows
7117 C                Q2MIN2  minimum Q**2 of photons (should be set to 0)
7118 C                Q2MAX2  maximum Q**2 of photons (if necessary,
7119 C                        corrected according size of hadron)
7120 C
7121 C**********************************************************************
7122       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7123       SAVE
7124
7125       PARAMETER ( PI   = 3.14159265359D0 )
7126
7127 C  input/output channels
7128       INTEGER LI,LO
7129       COMMON /POINOU/ LI,LO
7130 C  model switches and parameters
7131       CHARACTER*8 MDLNA
7132       INTEGER ISWMDL,IPAMDL
7133       DOUBLE PRECISION PARMDL
7134       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7135 C  event debugging information
7136       INTEGER NMAXD
7137       PARAMETER (NMAXD=100)
7138       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7139      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7140       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7141      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7142 C  photon flux kinematics and cuts
7143       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
7144      &                 YMIN1,YMAX1,YMIN2,YMAX2,
7145      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7146      &                 THMIN1,THMAX1,THMIN2,THMAX2
7147       INTEGER          ITAG1,ITAG2
7148       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
7149      &                YMIN1,YMAX1,YMIN2,YMAX2,
7150      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7151      &                THMIN1,THMAX1,THMIN2,THMAX2,
7152      &                ITAG1,ITAG2
7153 C  gamma-lepton or gamma-hadron vertex information
7154       INTEGER IGHEL,IDPSRC,IDBSRC
7155       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
7156      &                 RADSRC,AMSRC,GAMSRC
7157       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
7158      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
7159      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
7160 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
7161       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
7162       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
7163       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
7164      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
7165
7166 C  standard particle data interface
7167       INTEGER NMXHEP
7168
7169       PARAMETER (NMXHEP=4000)
7170
7171       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
7172       DOUBLE PRECISION PHEP,VHEP
7173       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
7174      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
7175      &                VHEP(4,NMXHEP)
7176 C  extension to standard particle data interface (PHOJET specific)
7177       INTEGER IMPART,IPHIST,ICOLOR
7178       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
7179
7180 C  event weights and generated cross section
7181       INTEGER IPOWGC,ISWCUT,IVWGHT
7182       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
7183       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
7184      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
7185
7186       DIMENSION P1(4),P2(4)
7187
7188       WRITE(LO,'(2(/1X,A))')
7189      &  'PHO_GHHIAS: hadron-gamma event generation',
7190      &  '-----------------------------------------'
7191 C  hadron size and mass
7192       FM2GEV = 5.07D0
7193       HIMASS = DBLE(NA)*0.938D0
7194       HIMA2  = HIMASS**2
7195       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
7196       ALPHA  = DBLE(NZ**2)/137.D0
7197       AMP  = 0.938D0
7198       AMP2 = AMP**2
7199 C  correct Q2MAX2 according to hadron size
7200       Q2MAXH = 2.D0/HIRADI**2
7201       Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
7202       IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
7203 C  total hadron / heavy ion energy
7204       EE = EEN*DBLE(NA)
7205       GAMMA = EE/HIMASS
7206 C  setup /POFSRC/
7207       GAMSRC(2) = GAMMA
7208       RADSRC(2) = HIRADI
7209       AMSRC(2)  = HIMASS
7210 C  check kinematic limitations
7211       YMI = ECMIN**2/(4.D0*EE*EEP)
7212       IF(YMIN2.LT.YMI) THEN
7213         WRITE(LO,'(/1X,A,2E12.5)')
7214      &    'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
7215         YMIN2 = YMI
7216       ELSE IF(YMIN2.GT.YMI) THEN
7217         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
7218      &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
7219      &    '  INSTEAD OF',YMIN2
7220       ENDIF
7221 C  kinematic limitation
7222       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7223 C  debug output
7224       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
7225       WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV)        ',HIMASS
7226       WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION  RADIUS (GeV**-1) ',HIRADI
7227       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
7228      &  Q2MAX2
7229       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
7230      &  YMAX2
7231       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
7232      &  2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
7233       WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON      ',ECMIN,
7234      &  ECMAX
7235       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
7236       IF(Q2LOW2.GE.Q2MAX2) THEN
7237         WRITE(LO,'(/1X,A,2E12.4)')
7238      &    'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
7239         CALL PHO_ABORT
7240       ENDIF
7241 C  hadron numbers set to 0
7242       IDPSRC(1) = 0
7243       IDPSRC(2) = 0
7244       IDBSRC(1) = 0
7245       IDBSRC(2) = 0
7246 C
7247       Max_tab = 100
7248       YMAX = YMAX2
7249       YMIN = YMIN2
7250       XMAX = LOG(YMAX)
7251       XMIN = LOG(YMIN)
7252       XDEL = XMAX-XMIN
7253       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
7254       DO 102 I=1,Max_tab
7255         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
7256         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
7257         IF(Q2LOW2.GE.Q2MAX2) THEN
7258           WRITE(LO,'(/1X,A,2E12.4)')
7259      &      'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
7260           YMAX2 = MIN(Y1,YMAX2)
7261           GOTO 103
7262         ENDIF
7263  102  CONTINUE
7264  103  CONTINUE
7265 C
7266       X2MAX = LOG(YMAX2)
7267       X2MIN = LOG(YMIN2)
7268       X2DEL = X2MAX-X2MIN
7269       DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
7270       FLUX = 0.D0
7271       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
7272      &  'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
7273       DO 105 I=1,Max_tab
7274         Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
7275         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
7276         FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
7277      &        -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
7278         FLUX = FLUX+Y2*FF
7279         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
7280  105  CONTINUE
7281       FLUX = FLUX*DELLY
7282       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
7283      &  'PHO_GHHIAS: integrated flux:',FLUX
7284 C
7285 C  hadron
7286       P1(1) = 0.D0
7287       P1(2) = 0.D0
7288       P1(3) = -SQRT(EEP**2-AMP2)
7289       P1(4) = EEP
7290 C  photon
7291       EGAM = YMAX2*EE
7292       P2(1) = 0.D0
7293       P2(2) = 0.D0
7294       P2(3) = EGAM
7295       P2(4) = EGAM
7296       CALL PHO_SETPAR(1,2212,0,0.D0)
7297       CALL PHO_SETPAR(2,22,0,0.D0)
7298       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
7299 C
7300       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7301       Y2 = YMIN2
7302       WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
7303      &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7304 C
7305       CALL PHO_PHIST(-1,SIGMAX)
7306       CALL PHO_LHIST(-1,SIGMAX)
7307 C
7308 C  generation of events, flux calculation
7309
7310       AY1  = 0.D0
7311       AY2  = 0.D0
7312       AYS1 = 0.D0
7313       AYS2 = 0.D0
7314       Q22MIN = 1.D30
7315       Q22MAX = 0.D0
7316       Q22AVE = 0.D0
7317       Q22AV2 = 0.D0
7318       YY2MIN = 1.D30
7319       YY2MAX = 0.D0
7320       NITER = NEVENT
7321       NITERS = 0
7322       ITRY = 0
7323       ITRW = 0
7324       DO 200 I=1,NITER
7325 C  sample photon flux
7326  150    CONTINUE
7327         ITRY = ITRY+1
7328  175    CONTINUE
7329 C
7330           ITRW = ITRW+1
7331 C  select Y2
7332           Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
7333           Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
7334           IF(Q2LOW2.GE.Q2MAX2) GOTO 175
7335           Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
7336           WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
7337      &          -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7338           IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
7339      &        'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
7340           IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
7341 C  sample Q2
7342           IF(IPAMDL(174).EQ.1) THEN
7343             YEFF = 1.D0+(1.D0-Y2)**2
7344  186        CONTINUE
7345               Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
7346               WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
7347             IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
7348           ELSE
7349             Q2P2 = Q2LOW2
7350           ENDIF
7351 C  impact parameter
7352           GAIMP(2) = 1.D0/SQRT(Q2P2)
7353 C  form factor (squared)
7354           FF2 = 1.D0
7355           IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
7356           IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
7357 C  photon data
7358           GYY(2) = Y2
7359           GQ2(2) = Q2P2
7360
7361 C
7362 C  incoming hadron 1
7363           PINI(1,1) = 0.D0
7364           PINI(2,1) = 0.D0
7365           PINI(3,1) = SQRT(EEP**2-AMP2)
7366           PINI(4,1) = EEP
7367           PINI(5,1) = AMP
7368 C  incoming hadron 2
7369           PINI(1,2) = 0.D0
7370           PINI(2,2) = 0.D0
7371           PINI(3,2) = -SQRT(EE**2-AMP2)
7372           PINI(4,2) = EE
7373           PINI(5,2) = AMP
7374 C  outgoing hadron 2
7375           YQ2 = SQRT((1.D0-Y2)*Q2P2)
7376           Q2E = Q2P2/(4.D0*EE)
7377           E1Y = EE*(1.D0-Y2)
7378           CALL PHO_SFECFE(SIF,COF)
7379           PFIN(1,2) = YQ2*COF
7380           PFIN(2,2) = YQ2*SIF
7381           PFIN(3,2) = -E1Y+Q2E
7382           PFIN(4,2) = E1Y+Q2E
7383           PFIN(5,2) = 0.D0
7384           PFPHI(2) = ATAN2(COF,SIF)
7385           PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
7386 C  scattering hadron
7387           P1(1) = 0.D0
7388           P1(2) = 0.D0
7389           P1(3) = SQRT(EEP**2-AMP2)
7390           P1(4) = EEP
7391           Q2P1  = AMP2
7392 C  scattering photon
7393           P2(1) = -PFIN(1,2)
7394           P2(2) = -PFIN(2,2)
7395           P2(3) = PINI(3,2)-PFIN(3,2)
7396           P2(4) = PINI(4,2)-PFIN(4,2)
7397           ISIDE = 2
7398 C
7399 C  ECMS cut
7400         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
7401      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
7402         IF(GGECM.LT.0.1D0) GOTO 175
7403         GGECM = SQRT(GGECM)
7404         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
7405 C
7406         PGAM(1,1) = P1(1)
7407         PGAM(2,1) = P1(2)
7408         PGAM(3,1) = P1(3)
7409         PGAM(4,1) = P1(4)
7410         PGAM(5,1) = AMP
7411         PGAM(1,2) = P2(1)
7412         PGAM(2,2) = P2(2)
7413         PGAM(3,2) = P2(3)
7414         PGAM(4,2) = P2(4)
7415         PGAM(5,2) = -SQRT(Q2P2)
7416 C  photon helicities
7417         IGHEL(2) = 1
7418 C  user cuts
7419         CALL PHO_PRESEL(5,IREJ)
7420         IF(IREJ.NE.0) GOTO 175
7421 C  event generation
7422         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
7423         IF(IREJ.NE.0) GOTO 150
7424 C  cut on diffractive mass
7425         DO 250 K=1,NHEP
7426           IF(ISTHEP(K).EQ.30) THEN
7427             GHDIFF = PHEP(1,K)
7428             IF(GHDIFF.GE.PARMDL(175)) THEN
7429               GOTO 251
7430             ELSE
7431               GOTO 150
7432             ENDIF
7433           ENDIF
7434  250    CONTINUE
7435         WRITE(LO,'(/,1X,A)')
7436      &    'PHO_GHHIOF: no diffractive entry found'
7437           CALL PHO_PREVNT(-1)
7438         GOTO 150
7439  251    CONTINUE
7440 C  remove quasi-elastically scattered hadron
7441         DO 260 K=1,NHEP
7442           IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7443             XF = ABS(PHEP(3,K)/EEN)
7444             IF(XF.LT.PARMDL(72)) GOTO 150
7445 *           ISTHEP(K) = 2
7446             GOTO 261
7447           ENDIF
7448  260    CONTINUE
7449  261    CONTINUE
7450 C
7451 C  statistics
7452
7453         NITERS = NITERS+1
7454
7455         AY2  = AY2+Y2
7456         AYS2 = AYS2+Y2*Y2
7457         Q22AVE = Q22AVE+Q2P2
7458         Q22AV2 = Q22AV2+Q2P2*Q2P2
7459         Q22MIN = MIN(Q22MIN,Q2P2)
7460         Q22MAX = MAX(Q22MAX,Q2P2)
7461         YY2MIN = MIN(YY2MIN,Y2)
7462         YY2MAX = MAX(YY2MAX,Y2)
7463 C  histograms
7464         CALL PHO_PHIST(1,HSWGHT(0))
7465         CALL PHO_LHIST(1,HSWGHT(0))
7466  200  CONTINUE
7467 C
7468       WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7469       WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
7470       AY2  = AY2/DBLE(MAX(NITERS,1))
7471       AYS2 = AYS2/DBLE(MAX(NITERS,1))
7472       DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
7473       Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
7474       Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
7475       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
7476       WGMAX  = WGMAX2*LOG(YMAX2/YMIN2)
7477       WGY    = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
7478       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7479 C  output of statistics, histograms
7480       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7481      &'=========================================================',
7482      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
7483      &'========================================================='
7484       WRITE(LO,'(//1X,A,/3X,4I12)')
7485      &  'PHO_GHHIOF:SUMMARY:  NITER,    NITERS,    ITRY,     ITRW',
7486      &  NITER,NITERS,ITRY,ITRW
7487       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7488      &  WGY,WEIGHT
7489       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
7490      &  AY2,DAY2
7491       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
7492      &  YY2MIN,YY2MAX
7493       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
7494      &  Q22AVE,Q22AV2
7495       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
7496      &  Q22MIN,Q22MAX
7497 C
7498       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7499       IF(NITER.GT.1) THEN
7500         CALL PHO_PHIST(-2,WEIGHT)
7501         CALL PHO_LHIST(-2,WEIGHT)
7502       ELSE
7503         WRITE(LO,'(1X,A,I4)')
7504      &    'PHO_GHHIOF: no output of histograms',NITER
7505       ENDIF
7506
7507       END
7508
7509 *$ CREATE PHO_FITPAR.FOR
7510 *COPY PHO_FITPAR
7511 CDECK  ID>, PHO_FITPAR
7512       SUBROUTINE PHO_FITPAR(IOUTP)
7513 C**********************************************************************
7514 C
7515 C     read input parameters according to PDFs
7516 C
7517 C**********************************************************************
7518       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7519       SAVE
7520
7521       PARAMETER ( DEFA=-99999.D0,
7522      &            DEFB=-100000.D0,
7523      &           THOUS=1.D3)
7524
7525 C  input/output channels
7526       INTEGER LI,LO
7527       COMMON /POINOU/ LI,LO
7528 C  event debugging information
7529       INTEGER NMAXD
7530       PARAMETER (NMAXD=100)
7531       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7532      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7533       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7534      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7535 C  model switches and parameters
7536       CHARACTER*8 MDLNA
7537       INTEGER ISWMDL,IPAMDL
7538       DOUBLE PRECISION PARMDL
7539       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7540 C  global event kinematics and particle IDs
7541       INTEGER IFPAP,IFPAB
7542       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
7543       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
7544 C  currently activated parton density parametrizations
7545       CHARACTER*8 PDFNAM
7546       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
7547       DOUBLE PRECISION PDFLAM,PDFQ2M
7548       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
7549      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
7550 C  Reggeon phenomenology parameters
7551       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
7552      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
7553       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
7554      &                ALREG,ALREGP,GR(2),B0REG(2),
7555      &                GPPP,GPPR,B0PPP,B0PPR,
7556      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
7557 C  parameters of 2x2 channel model
7558       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
7559       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
7560
7561       DIMENSION   INUM(3),IFPAS(2)
7562       CHARACTER*8 CNAME8,PDFNA1,PDFNA2
7563       CHARACTER*10 CNAM10
7564
7565       PARAMETER ( Max_tab = 22 )
7566       DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
7567       REAL XDPtab
7568       INTEGER IDPtab
7569
7570 C  parameter set for   2212 (GRV94 LO)     2212 (GRV94 LO)
7571       DATA (IDPtab(k,  1),k=1,8) /
7572      &    2212,     5,     6,     0,  2212,     5,     6,     0 /
7573       DATA (XDPtab(k,  1),k=1,27) /
7574      &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7575      &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
7576      &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7577      &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7578      &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7579
7580 C  parameter set for   2212 (GRV94 LO)    -2212 (GRV94 LO)
7581       DATA (IDPtab(k,  2),k=1,8) /
7582      &    2212,     5,     6,     0, -2212,     5,     6,     0 /
7583       DATA (XDPtab(k,  2),k=1,27) /
7584      &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7585      &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
7586      &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7587      &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7588      &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7589
7590 C  parameter set for     22 (GRV-G LO)     2212 (GRV94 LO)
7591       DATA (IDPtab(k,  3),k=1,8) /
7592      &      22,     5,     3,     0,  2212,     5,     6,     0 /
7593       DATA (XDPtab(k,  3),k=1,27) /
7594      &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7595      &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7596      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7597      &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7598      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7599
7600 C  parameter set for     22 (GRV-G LO)       22 (GRV-G LO)
7601       DATA (IDPtab(k,  4),k=1,8) /
7602      &      22,     5,     3,     0,    22,     5,     3,     0 /
7603       DATA (XDPtab(k,  4),k=1,27) /
7604      &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7605      &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7606      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7607      &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7608      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7609
7610 C  parameter set for     22 (GRS-G LO)     2212 (GRV94 LO)
7611       DATA (IDPtab(k,  5),k=1,8) /
7612      &      22,     5,     4,     4,  2212,     5,     6,     0 /
7613       DATA (XDPtab(k,  5),k=1,27) /
7614      &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7615      &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7616      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7617      &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7618      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7619
7620 C  parameter set for     22 (GRS-G LO)       22 (GRS-G LO)
7621       DATA (IDPtab(k,  6),k=1,8) /
7622      &      22,     5,     4,     4,    22,     5,     4,     4 /
7623       DATA (XDPtab(k,  6),k=1,27) /
7624      &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7625      &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7626      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7627      &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7628      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7629
7630 C  parameter set for     22 (SaS-1D  )       22 (SaS-1D  )
7631       DATA (IDPtab(k,  7),k=1,8) /
7632      &      22,     1,     1,     4,    22,     1,     1,     4 /
7633       DATA (XDPtab(k,  7),k=1,27) /
7634      &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
7635      &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
7636      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7637      &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
7638      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7639
7640 C  parameter set for     22 (SaS-1M  )       22 (SaS-1M  )
7641       DATA (IDPtab(k,  8),k=1,8) /
7642      &      22,     1,     2,     4,    22,     1,     2,     4 /
7643       DATA (XDPtab(k,  8),k=1,27) /
7644      &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
7645      &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
7646      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7647      &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7648      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7649
7650 C  parameter set for     22 (SaS-2D  )       22 (SaS-2D  )
7651       DATA (IDPtab(k,  9),k=1,8) /
7652      &      22,     1,     3,     4,    22,     1,     3,     4 /
7653       DATA (XDPtab(k,  9),k=1,27) /
7654      &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
7655      &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
7656      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7657      &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7658      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7659
7660 C  parameter set for     22 (SaS-2M  )       22 (SaS-2M  )
7661       DATA (IDPtab(k, 10),k=1,8) /
7662      &      22,     1,     4,     4,    22,     1,     4,     4 /
7663       DATA (XDPtab(k, 10),k=1,27) /
7664      &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
7665      &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
7666      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7667      &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+00,1.0000E+00,
7668      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7669
7670 C  parameter set for     22 (LAC     )     2212 (GRV94 LO)
7671       DATA (IDPtab(k, 11),k=1,8) /
7672      &      22,     3,     1,     3,  2212,     5,     6,     0 /
7673       DATA (XDPtab(k, 11),k=1,27) /
7674      &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7675      &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7676      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7677      &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7678      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7679
7680 C  parameter set for     22 (PDFLIB2 )     2212 (GRV94 LO)
7681       DATA (IDPtab(k, 12),k=1,8) /
7682      &      22,     3,     1,     2,  2212,     5,     6,     0 /
7683       DATA (XDPtab(k, 12),k=1,27) /
7684      &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7685      &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7686      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7687      &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7688      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7689
7690 C  parameter set for     22 (LAC     )       22 (LAC     )
7691       DATA (IDPtab(k, 13),k=1,8) /
7692      &      22,     3,     1,     3,    22,     3,     1,     3 /
7693       DATA (XDPtab(k, 13),k=1,27) /
7694      &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7695      &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7696      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7697      &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7698      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7699
7700 C  parameter set for     22 (PDFLIB2 )       22 (PDFLIB2 )
7701       DATA (IDPtab(k, 14),k=1,8) /
7702      &      22,     3,     1,     2,    22,     3,     1,     2 /
7703       DATA (XDPtab(k, 14),k=1,27) /
7704      &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7705      &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7706      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7707      &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7708      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7709
7710 C  parameter set for     22 (LAC     )     2212 (GRV94 LO)
7711       DATA (IDPtab(k, 15),k=1,8) /
7712      &      22,     3,     2,     3,  2212,     5,     6,     0 /
7713       DATA (XDPtab(k, 15),k=1,27) /
7714      &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7715      &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7716      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7717      &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7718      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7719
7720 C  parameter set for     22 (PDFLIB2 )     2212 (GRV94 LO)
7721       DATA (IDPtab(k, 16),k=1,8) /
7722      &      22,     3,     2,     2,  2212,     5,     6,     0 /
7723       DATA (XDPtab(k, 16),k=1,27) /
7724      &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7725      &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7726      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7727      &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7728      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7729
7730 C  parameter set for     22 (LAC     )       22 (LAC     )
7731       DATA (IDPtab(k, 17),k=1,8) /
7732      &      22,     3,     2,     3,    22,     3,     2,     3 /
7733       DATA (XDPtab(k, 17),k=1,27) /
7734      &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7735      &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7736      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7737      &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7738      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7739
7740 C  parameter set for     22 (PDFLIB2 )       22 (PDFLIB2 )
7741       DATA (IDPtab(k, 18),k=1,8) /
7742      &      22,     3,     2,     2,    22,     3,     2,     2 /
7743       DATA (XDPtab(k, 18),k=1,27) /
7744      &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7745      &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7746      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7747      &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7748      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7749
7750 C  parameter set for     22 (LAC     )     2212 (GRV94 LO)
7751       DATA (IDPtab(k, 19),k=1,8) /
7752      &      22,     3,     3,     3,  2212,     5,     6,     0 /
7753       DATA (XDPtab(k, 19),k=1,27) /
7754      &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7755      &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7756      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7757      &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7758      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7759
7760 C  parameter set for     22 (PDFLIB2 )     2212 (GRV94 LO)
7761       DATA (IDPtab(k, 20),k=1,8) /
7762      &      22,     3,     3,     2,  2212,     5,     6,     0 /
7763       DATA (XDPtab(k, 20),k=1,27) /
7764      &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7765      &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7766      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7767      &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7768      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7769
7770 C  parameter set for     22 (LAC     )       22 (LAC     )
7771       DATA (IDPtab(k, 21),k=1,8) /
7772      &      22,     3,     3,     3,    22,     3,     3,     3 /
7773       DATA (XDPtab(k, 21),k=1,27) /
7774      &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7775      &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7776      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7777      &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7778      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7779
7780 C  parameter set for     22 (PDFLIB2 )       22 (PDFLIB2 )
7781       DATA (IDPtab(k, 22),k=1,8) /
7782      &      22,     3,     3,     2,    22,     3,     3,     2 /
7783       DATA (XDPtab(k, 22),k=1,27) /
7784      &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7785      &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7786      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7787      &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7788      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7789
7790       DATA CNAME8 /'        '/
7791       DATA CNAM10 /'          '/
7792       DATA INIT / 0 /
7793       DATA IFPAS / 0, 0 /
7794
7795       IF((INIT.EQ.1).AND.
7796      &   (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
7797
7798       INIT=1
7799       IFPAS(1) = IFPAP(1)
7800       IFPAS(2) = IFPAP(2)
7801
7802 C  parton distribution functions
7803       CALL PHO_ACTPDF(IFPAP(1),1)
7804       CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7805       CALL PHO_ACTPDF(IFPAP(2),2)
7806       CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7807 C  initialize alpha_s calculation
7808       DUMMY = PHO_ALPHAS(0.D0,-4)
7809
7810       IF(IDEB(54).GE.0) THEN
7811         WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7812      &    IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
7813         WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7814      &    IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
7815       ENDIF
7816
7817       IFOUND = 0
7818
7819 C  load parameter set from internal tables
7820       I1 = 1
7821       I2 = 2
7822  110  CONTINUE
7823
7824       DO I=1,Max_tab
7825         IF((IFPAP(I1).EQ.IDPtab(1,I))
7826      &     .AND.(IGRP(I1).EQ.IDPtab(2,I))
7827      &     .AND.(ISET(I1).EQ.IDPtab(3,I))
7828      &     .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
7829           IF((IFPAP(I2).EQ.IDPtab(5,I))
7830      &       .AND.(IGRP(I2).EQ.IDPtab(6,I))
7831      &       .AND.(ISET(I2).EQ.IDPtab(7,I))
7832      &       .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
7833             WRITE(LO,'(/1X,A)')
7834      &        'PHO_FITPAR: parameter set found in internal table'
7835             ALPOM    = XDPtab(1,I)
7836             ALPOMP   = XDPtab(2,I)
7837             GP(I1)   = XDPtab(3,I)
7838             GP(I2)   = XDPtab(4,I)
7839             B0POM(I1) = XDPtab(5,I)
7840             B0POM(I2) = XDPtab(6,I)
7841             ALREG    = XDPtab(7,I)
7842             ALREGP   = XDPtab(8,I)
7843             GR(I1)   = XDPtab(9,I)
7844             GR(I2)   = XDPtab(10,I)
7845             B0REG(I1) = XDPtab(11,I)
7846             B0REG(I2) = XDPtab(12,I)
7847             GPPP     = XDPtab(13,I)
7848             B0PPP    = XDPtab(14,I)
7849             GPPR     = XDPtab(15,I)
7850             B0PPR    = XDPtab(16,I)
7851             VDMFAC(2*I1-1) = XDPtab(17,I)
7852             VDMFAC(2*I1)   = XDPtab(18,I)
7853             VDMFAC(2*I2-1) = XDPtab(19,I)
7854             VDMFAC(2*I2)   = XDPtab(20,I)
7855             B0HAR    = XDPtab(21,I)
7856             AKFAC    = XDPtab(22,I)
7857             PHISUP(I1) = XDPtab(23,I)
7858             PHISUP(I2) = XDPtab(24,I)
7859             RMASS(I1) = XDPtab(25,I)
7860             RMASS(I2) = XDPtab(26,I)
7861             VAR      = XDPtab(27,I)
7862             IFOUND = 1
7863             GOTO 1200
7864           ENDIF
7865         ENDIF
7866       ENDDO
7867
7868       IF(I1.EQ.1) THEN
7869         I1 = 2
7870         I2 = 1
7871         GOTO 110
7872       ELSE
7873         WRITE(LO,'(/1X,A)')
7874      &    'PHO_FITPAR: parameter set not found in internal table'
7875       ENDIF
7876
7877  1200 CONTINUE
7878
7879 C  get parameters of soft cross sections from fitpar.dat
7880       IF(IPAMDL(99).GT.IFOUND) THEN
7881
7882         WRITE(LO,'(/1X,A)')
7883      &    'PHO_FITPAR: loading parameter set from file fitpar.dat'
7884         OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
7885
7886  100    CONTINUE
7887           READ(12,'(A8)',ERR=1020,END=1010) CNAME8
7888           IF(CNAME8.EQ.'STOP') GOTO 1010
7889           IF(CNAME8.EQ.'NEXTDATA') THEN
7890             READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7891      &        IDPA1,CNAME8,INUM
7892             IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
7893      &         .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
7894               READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7895      &          IDPA2,CNAME8,INUM
7896               IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
7897      &           (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
7898                 WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
7899                 READ(12,*) ALPOM,ALPOMP,GP,B0POM
7900                 READ(12,*) ALREG,ALREGP,GR,B0REG
7901                 READ(12,*) GPPP,B0PPP,GPPR,B0PPR
7902                 READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
7903                 READ(12,*) B0HAR
7904                 READ(12,*) AKFAC
7905                 READ(12,*) PHISUP
7906                 READ(12,*) RMASS,VAR
7907                 IFOUND = 1
7908                 GOTO 1100
7909               ENDIF
7910             ENDIF
7911           ENDIF
7912         GOTO 100
7913
7914  1020 CONTINUE
7915         WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
7916         WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
7917  1010 CONTINUE
7918         WRITE(LO,'(/A)')
7919      &    ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
7920
7921  1100   CONTINUE
7922         CLOSE(12)
7923
7924       ENDIF
7925
7926 C  nothing found
7927       IF(IFOUND.EQ.0) THEN
7928         WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
7929         WRITE(LO,'(3(10X,A,/))')
7930      &    '(copy fitpar.dat into the working directory and/or',
7931      &    ' request the missing parameter set via e-mail from',
7932      &    ' ralph.engel@fzk.de)'
7933         STOP
7934       ENDIF
7935
7936  1300 CONTINUE
7937
7938 C  overwrite parameters with user settings
7939       IF(PARMDL(301).GT.DEFA) THEN
7940         ALPOM     = PARMDL(301)
7941         PARMDL(301) = DEFB
7942       ENDIF
7943       IF(PARMDL(302).GT.DEFA) THEN
7944         ALPOMP    = PARMDL(302)
7945         PARMDL(302) = DEFB
7946       ENDIF
7947       IF(PARMDL(303).GT.DEFA) THEN
7948         GP(1)     = PARMDL(303)
7949         PARMDL(303) = DEFB
7950       ENDIF
7951       IF(PARMDL(304).GT.DEFA) THEN
7952         GP(2)     = PARMDL(304)
7953         PARMDL(304) = DEFB
7954       ENDIF
7955       IF(PARMDL(305).GT.DEFA) THEN
7956         B0POM(1)  = PARMDL(305)
7957         PARMDL(305) = DEFB
7958       ENDIF
7959       IF(PARMDL(306).GT.DEFA) THEN
7960         B0POM(2)  = PARMDL(306)
7961         PARMDL(306) = DEFB
7962       ENDIF
7963       IF(PARMDL(307).GT.DEFA) THEN
7964         ALREG     = PARMDL(307)
7965         PARMDL(307) = DEFB
7966       ENDIF
7967       IF(PARMDL(308).GT.DEFA) THEN
7968         ALREGP    = PARMDL(308)
7969         PARMDL(308) = DEFB
7970       ENDIF
7971       IF(PARMDL(309).GT.DEFA) THEN
7972         GR(1)     = PARMDL(309)
7973         PARMDL(309) = DEFB
7974       ENDIF
7975       IF(PARMDL(310).GT.DEFA) THEN
7976         GR(2)      = PARMDL(310)
7977         PARMDL(310) = DEFB
7978       ENDIF
7979       IF(PARMDL(311).GT.DEFA) THEN
7980         B0REG(1)  = PARMDL(311)
7981         PARMDL(311) = DEFB
7982       ENDIF
7983       IF(PARMDL(312).GT.DEFA) THEN
7984         B0REG(2)  = PARMDL(312)
7985         PARMDL(312) = DEFB
7986       ENDIF
7987       IF(PARMDL(313).GT.DEFA) THEN
7988         GPPP      = PARMDL(313)
7989         PARMDL(313) = DEFB
7990       ENDIF
7991       IF(PARMDL(314).GT.DEFA) THEN
7992         B0PPP     = PARMDL(314)
7993         PARMDL(314)= DEFB
7994       ENDIF
7995       IF(PARMDL(315).GT.DEFA) THEN
7996         VDMFAC(1) = PARMDL(315)
7997         PARMDL(315)= DEFB
7998       ENDIF
7999       IF(PARMDL(316).GT.DEFA) THEN
8000         VDMFAC(2) = PARMDL(316)
8001         PARMDL(316)= DEFB
8002       ENDIF
8003       IF(PARMDL(317).GT.DEFA) THEN
8004         VDMFAC(3) = PARMDL(317)
8005         PARMDL(317)= DEFB
8006       ENDIF
8007       IF(PARMDL(318).GT.DEFA) THEN
8008         VDMFAC(4) = PARMDL(318)
8009         PARMDL(318)= DEFB
8010       ENDIF
8011       IF(PARMDL(319).GT.DEFA) THEN
8012         B0HAR     = PARMDL(319)
8013         PARMDL(319)= DEFB
8014       ENDIF
8015       IF(PARMDL(320).GT.DEFA) THEN
8016         AKFAC     = PARMDL(320)
8017         PARMDL(320)= DEFB
8018       ENDIF
8019       IF(PARMDL(321).GT.DEFA) THEN
8020         PHISUP(1) = PARMDL(321)
8021         PARMDL(321)= DEFB
8022       ENDIF
8023       IF(PARMDL(322).GT.DEFA) THEN
8024         PHISUP(2) = PARMDL(322)
8025         PARMDL(322)= DEFB
8026       ENDIF
8027       IF(PARMDL(323).GT.DEFA) THEN
8028         RMASS(1)  = PARMDL(323)
8029         PARMDL(323)= DEFB
8030       ENDIF
8031       IF(PARMDL(324).GT.DEFA) THEN
8032         RMASS(2)  = PARMDL(324)
8033         PARMDL(324)= DEFB
8034       ENDIF
8035       IF(PARMDL(325).GT.DEFA) THEN
8036         VAR       = PARMDL(325)
8037         PARMDL(325)= DEFB
8038       ENDIF
8039       IF(PARMDL(327).GT.DEFA) THEN
8040         GPPR      = PARMDL(327)
8041         PARMDL(327)= DEFB
8042       ENDIF
8043       IF(PARMDL(328).GT.DEFA) THEN
8044         B0PPR     = PARMDL(328)
8045         PARMDL(328)= DEFB
8046       ENDIF
8047
8048       VDMQ2F(1) = VDMFAC(1)
8049       VDMQ2F(2) = VDMFAC(2)
8050       VDMQ2F(3) = VDMFAC(3)
8051       VDMQ2F(4) = VDMFAC(4)
8052
8053 C  output of parameter set
8054       IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
8055         WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
8056      &                       ' -------------------------'
8057         WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8058      &  '  ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
8059      &  B0POM
8060         WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8061      &  '  ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
8062      &  B0REG
8063         WRITE(LO,'(4(A,F7.3))')
8064      &  '  GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
8065         WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
8066         WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
8067         WRITE(LO,'(A,F8.3)')  '  B0HAR:',B0HAR
8068         WRITE(LO,'(A,F8.3)')  '  AKFAC:',AKFAC
8069         WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
8070         WRITE(LO,'(A,3F8.3)') '  RMASS:',RMASS,VAR
8071       ENDIF
8072
8073       CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
8074
8075       END
8076
8077 *$ CREATE PHO_BORNCS.FOR
8078 *COPY PHO_BORNCS
8079 CDECK  ID>, PHO_BORNCS
8080       SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
8081 C*********************************************************************
8082 C
8083 C     calculation of Born graph cross sections and slopes
8084 C
8085 C     input: IP               particle combination
8086 C            IFHARD           -1 calculate hard Born graph cross section
8087 C                             0  take hard Born graph cross section
8088 C                                from interpolation table if available
8089 C                             1  assume that correct hard cross
8090 C                                sections are already stored in /POSBRN/
8091 C            XM1,XM2,XM3,XM4  masses of external lines
8092 C                   /GLOCMS/  energy and PT cut-off
8093 C                   /POPREG/  soft and hard parameters
8094 C                   /POSBRN/  input cross sections
8095 C                   /POZBRN/  scaled input values
8096 C                    IFHARD   0  calculate hard input cross sections
8097 C                             1  assume hard input cross sections exist
8098 C
8099 C     output: ZPOM            scaled pomeron cross section
8100 C             ZIGR            scaled reggeon cross section
8101 C             ZIGHR           scaled hard resolved cross section
8102 C             ZIGHD           scaled hard direct cross section
8103 C             ZIGT1           scaled triple-Pomeron cross section
8104 C             ZIGT2           scaled triple-Pomeron cross section
8105 C             ZIGL            scaled loop-Pomeron cross section
8106 C
8107 C*********************************************************************
8108       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8109       SAVE
8110
8111       PARAMETER(ITWO=2,
8112      &        ITHREE=3,
8113      &         IFOUR=4,
8114      &         IFIVE=5,
8115      &          FIVE=5.D0,
8116      &         THOUS=1.D3,
8117      &           EPS=0.01D0,
8118      &          DEPS=1.D-30)
8119
8120 C  input/output channels
8121       INTEGER LI,LO
8122       COMMON /POINOU/ LI,LO
8123 C  some constants
8124       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
8125       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
8126      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
8127 C  event debugging information
8128       INTEGER NMAXD
8129       PARAMETER (NMAXD=100)
8130       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8131      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8132       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8133      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8134 C  model switches and parameters
8135       CHARACTER*8 MDLNA
8136       INTEGER ISWMDL,IPAMDL
8137       DOUBLE PRECISION PARMDL
8138       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8139 C  names of hard scattering processes
8140       INTEGER Max_pro_1
8141       PARAMETER ( Max_pro_1 = 16 )
8142       CHARACTER*18 PROC
8143       COMMON /POHPRO/ PROC(0:Max_pro_1)
8144 C  hard cross sections and MC selection weights
8145       INTEGER Max_pro_2
8146       PARAMETER ( Max_pro_2 = 16 )
8147       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
8148      &  MH_acc_1,MH_acc_2
8149       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
8150       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
8151      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
8152      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
8153      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
8154      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
8155 C  interpolation tables for hard cross section and MC selection weights
8156       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
8157       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
8158       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
8159       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
8160      &  HQ2a_tab,HQ2b_tab,HEcm_tab
8161       COMMON /POHTAB/
8162      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8163      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8164      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8165      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8166      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
8167      &  HEcm_tab(1:Max_tab_E,0:4),
8168      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
8169 C  Born graph cross sections and slopes
8170       INTEGER Max_pro_3
8171       PARAMETER ( Max_pro_3 = 16 )
8172       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8173      &                SIGD1,SIGD2,DSIGH
8174       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8175      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8176 C  scaled cross sections and slopes
8177       COMPLEX*16      ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8178      &                ZIGD1,ZIGD2,
8179      &                BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8180       COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8181      &                ZIGDP(4),ZIGD1(2),ZIGD2(2),
8182      &                BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8183      &                BD1(2),BD2(2)
8184 C  Reggeon phenomenology parameters
8185       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8186      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8187       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8188      &                ALREG,ALREGP,GR(2),B0REG(2),
8189      &                GPPP,GPPR,B0PPP,B0PPR,
8190      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8191 C  parameters of 2x2 channel model
8192       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8193       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8194 C  data of c.m. system of Pomeron / Reggeon exchange
8195       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8196       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8197      &                 SIDP,CODP,SIFP,COFP
8198       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8199      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
8200      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
8201 C  obsolete cut-off information
8202       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
8203       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
8204 C  data needed for soft-pt calculation
8205       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
8206       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
8207
8208       COMPLEX*16      CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
8209      &                BPOM1,BPOM2,BREG1,BREG2,B0HARD
8210       DIMENSION       SCB1(4),SCB2(4),SCG1(4),SCG2(4)
8211       DIMENSION       BT14(2),BT24(2),BD4(4)
8212       DIMENSION       DSPT(0:Max_pro_2)
8213
8214       DATA  XMPOM / 0.766D0 /
8215       DATA  CZERO /(0.D0,0.D0)/
8216
8217       CDABS(SS) = ABS(SS)
8218       DCMPLX(X,Y) = CMPLX(X,Y)
8219
8220 C  debug output
8221       IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
8222      &  'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
8223 C  scales
8224       CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
8225 C
8226 C  calculate hard input cross sections (output in mb)
8227       IF(IFHARD.NE.1) THEN
8228         IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
8229 C  double-log interpolation
8230           CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
8231           DO 60 M=0,Max_pro_2
8232             DSIGH(M) = HSig(M)
8233             DSPT(M)  = Hdpt(M)
8234  60       CONTINUE
8235         ELSE
8236 C  new calculation
8237           CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
8238           CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
8239         ENDIF
8240 C
8241 C  save values to calculate soft pt distribution
8242         IF(IP.EQ.1) THEN
8243           VDMQ2F(1) = VDMFAC(1)
8244           VDMQ2F(2) = VDMFAC(2)
8245           VDMQ2F(3) = VDMFAC(3)
8246           VDMQ2F(4) = VDMFAC(4)
8247         ELSE IF(IP.EQ.2) THEN
8248           VDMQ2F(1) = VDMFAC(1)
8249           VDMQ2F(2) = VDMFAC(2)
8250           VDMQ2F(3) = 1.D0
8251           VDMQ2F(4) = 0.D0
8252         ELSE IF(IP.EQ.3) THEN
8253           VDMQ2F(1) = VDMFAC(3)
8254           VDMQ2F(2) = VDMFAC(4)
8255           VDMQ2F(3) = 1.D0
8256           VDMQ2F(4) = 0.D0
8257         ELSE
8258           VDMQ2F(1) = 1.D0
8259           VDMQ2F(2) = 0.D0
8260           VDMQ2F(3) = 1.D0
8261           VDMQ2F(4) = 0.D0
8262         ENDIF
8263 C  VDM factors
8264         AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
8265         AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
8266         AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
8267         AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
8268         ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
8269      &             +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
8270         ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
8271         ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
8272         ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
8273         VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
8274      &        +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
8275         DSIGHP = DSPT(9)/VFAC
8276         SIGH   = DSIGH(9)/VFAC
8277 C  extract real part
8278         IF(IPAMDL(1).EQ.0) THEN
8279           DO 50 I=0,Max_pro_2
8280             DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
8281  50       CONTINUE
8282         ENDIF
8283 C  write out results
8284         IF(IDEB(48).GE.15) THEN
8285           WRITE(LO,'(/1X,A,1P,2E11.3)')
8286      &       'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
8287           DO 200 I=0,Max_pro_2
8288             WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
8289  200      CONTINUE
8290         ENDIF
8291       ENDIF
8292
8293 C  DPMJET interface: subtract anomalous part
8294       IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
8295      &  DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
8296
8297       SCALE = CDABS(DSIGH(15))
8298       IF(SCALE.LT.DEPS) THEN
8299         SIGHD=CZERO
8300       ELSE
8301         SIGHD=DSIGH(15)
8302       ENDIF
8303       SCALE = CDABS(DSIGH(9))
8304       IF(SCALE.LT.DEPS) THEN
8305         SIGHR=CZERO
8306       ELSE
8307         SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
8308       ENDIF
8309
8310 C  calculate soft input cross sections (output in mb)
8311       SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
8312       IF(IPAMDL(1).EQ.1) THEN
8313 C  pomeron signature
8314         SP=SS*DCMPLX(0.D0,-1.D0)
8315 C  reggeon signature
8316         SR=SS*DCMPLX(0.D0,1.D0)
8317       ELSE
8318         SP=SS
8319         SR=SS
8320       ENDIF
8321 C  coupling constants (mb**1/2)
8322 C  particle dependent slopes (GeV**-2)
8323       IF(IP.EQ.1) THEN
8324         GP1 = GP(1)
8325         GP2 = GP(2)
8326         GR1 = GR(1)
8327         GR2 = GR(2)
8328         B0POM1 = B0POM(1)
8329         B0POM2 = B0POM(2)
8330         B0REG1 = B0REG(1)
8331         B0REG2 = B0REG(2)
8332         B0HARD = B0HAR
8333         RMASS1 = RMASS(1)
8334         RMASS2 = RMASS(2)
8335       ELSE IF(IP.EQ.2) THEN
8336         GP1 = GP(1)
8337         GP2 = PARMDL(77)
8338         GR1 = GR(1)
8339         GR2 = PARMDL(77)*GPPR/GPPP
8340         B0POM1 = B0POM(1)
8341         B0POM2 = B0PPP
8342         B0REG1 = B0REG(1)
8343         B0REG2 = B0PPR
8344         B0HARD = B0POM1+B0POM2
8345         RMASS1 = RMASS(1)
8346         RMASS2 = XMPOM
8347       ELSE IF(IP.EQ.3) THEN
8348         GP1 = GP(2)
8349         GP2 = PARMDL(77)
8350         GR1 = GR(2)
8351         GR2 = PARMDL(77)*GPPR/GPPP
8352         B0POM1 = B0POM(2)
8353         B0POM2 = B0PPP
8354         B0REG1 = B0REG(2)
8355         B0REG2 = B0PPR
8356         B0HARD = B0POM1+B0POM2
8357         RMASS1 = RMASS(2)
8358         RMASS2 = XMPOM
8359       ELSE IF(IP.EQ.4) THEN
8360         GP1 = PARMDL(77)
8361         GP2 = GP1
8362         GR1 = PARMDL(77)*GPPR/GPPP
8363         GR2 = GR1
8364         B0POM1 = B0PPP
8365         B0POM2 = B0PPP
8366         B0REG1 = B0PPR
8367         B0REG2 = B0PPR
8368         B0HARD = B0POM1+B0POM2
8369         RMASS1 = XMPOM
8370         RMASS2 = XMPOM
8371       ELSE
8372         WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
8373         CALL PHO_ABORT
8374       ENDIF
8375       GP1 = GP1*SCALE1
8376       GP2 = GP2*SCALE2
8377       GR1 = GR1*SCALE1
8378       GR2 = GR2*SCALE2
8379 C  input slope parameters (GeV**-2)
8380       BPOM1 = B0POM1*SCALB1
8381       BPOM2 = B0POM2*SCALB2
8382       BREG1 = B0REG1*SCALB1
8383       BREG2 = B0REG2*SCALB2
8384 C  effective slopes
8385       XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
8386       SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
8387       BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
8388       BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
8389       IF(IPAMDL(9).EQ.0) THEN
8390         BHAR = B0HARD
8391         BHAD = B0HARD
8392       ELSE IF(IPAMDL(9).EQ.1) THEN
8393         BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
8394         BHAD = BHAR
8395       ELSE IF(IPAMDL(9).EQ.2) THEN
8396         BHAR = BPOM1+BPOM2
8397         BHAD = BHAR
8398       ELSE
8399         BHAR = BPOM
8400         BHAD = BPOM
8401       ENDIF
8402 C  input cross section pomeron
8403       SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
8404       SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
8405 C  save value to calculate soft pt distribution
8406       SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
8407
8408 C  higher order graphs
8409       VIRT1 = PVIRTP(1)
8410       VIRT2 = PVIRTP(2)
8411 C  bare/renormalized intercept for enhanced graphs
8412       IF(IPAMDL(8).EQ.0) THEN
8413         DELTAP = ALPOM-1.D0
8414       ELSE
8415         DELTAP = PARMDL(48)-1.D0
8416       ENDIF
8417       SD = ECMP**2
8418       BP1 = 2.D0*BPOM1
8419       BP2 = 2.D0*BPOM2
8420 C  input cross section high-mass double diffraction
8421       CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
8422      &            DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
8423       SIGL = DCMPLX(SIGTR,0.D0)
8424       BLOO = DCMPLX(BTR,0.D0)
8425 C
8426 C  input cross section high mass diffraction particle 1
8427 C  first possibility
8428       CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8429      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8430       CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8431      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8432       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8433       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8434       BP1 = 2.D0*BPOM1*SCALB1
8435       BP2 = 2.D0*BPOM2*SCALB2
8436 C  input cross section high mass diffraction
8437       CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8438      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8439       SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8440       BTR1(1)  = DCMPLX(BTR,0.D0)
8441 C  second possibility:  high-low mass double diffraction
8442       CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8443      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8444       CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8445      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8446       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8447       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8448       BP1 = 2.D0*BPOM1*SCALB1
8449       BP2 = 2.D0*BPOM2*SCALB2
8450 C  input cross section high mass diffraction
8451       CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8452      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8453       SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8454       BTR1(2)  = DCMPLX(BTR,0.D0)
8455 C
8456 C  input cross section high mass diffraction particle 2
8457 C  first possibility
8458       CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8459      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8460       CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8461      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8462       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8463       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8464       BP1 = 2.D0*BPOM1*SCALB1
8465       BP2 = 2.D0*BPOM2*SCALB2
8466 C  input cross section high mass diffraction
8467       CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8468      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8469       SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8470       BTR2(1)  = DCMPLX(BTR,0.D0)
8471 C  second possibility:  high-low mass double diffraction
8472       CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8473      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8474       CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8475      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8476       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8477       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8478       BP1 = 2.D0*BPOM1*SCALB1
8479       BP2 = 2.D0*BPOM2*SCALB2
8480 C  input cross section high mass diffraction
8481       CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8482      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8483       SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8484       BTR2(2)  = DCMPLX(BTR,0.D0)
8485 C
8486 C  input cross section for loop-pomeron
8487 C  first possibility
8488       CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8489      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8490       CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8491      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8492       CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8493      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8494       CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8495      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8496       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8497       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8498       BP1 = BPOM1*SCALB1
8499       BP2 = BPOM2*SCALB2
8500       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8501      &  SIGTX,BTX)
8502       SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8503       BDP(1)   = DCMPLX(BTX,0.D0)
8504 C  second possibility
8505       CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8506      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8507       CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8508      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8509       CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8510      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8511       CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8512      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8513       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8514       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8515       BP1 = BPOM1*SCALB1
8516       BP2 = BPOM2*SCALB2
8517       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8518      &  SIGTX,BTX)
8519       SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8520       BDP(2)   = DCMPLX(BTX,0.D0)
8521 C  third possibility
8522       CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8523      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8524       CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8525      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8526       CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8527      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8528       CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8529      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8530       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8531       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8532       BP1 = BPOM1*SCALB1
8533       BP2 = BPOM2*SCALB2
8534       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8535      &  SIGTX,BTX)
8536       SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8537       BDP(3)   = DCMPLX(BTX,0.D0)
8538 C  fourth possibility
8539       CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8540      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8541       CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8542      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8543       CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8544      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8545       CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8546      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8547       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8548       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8549       BP1 = BPOM1*SCALB1
8550       BP2 = BPOM2*SCALB2
8551       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8552      &  SIGTX,BTX)
8553       SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8554       BDP(4)   = DCMPLX(BTX,0.D0)
8555 C
8556 C  input cross section for YY-iterated triple-pomeron
8557 C     .....
8558 C
8559 C  write out input cross sections
8560       IF(IDEB(48).GE.5) THEN
8561         WRITE(LO,'(2(/1X,A))')
8562      &    'Born graph input cross sections and slopes',
8563      &    '------------------------------------------'
8564         WRITE(LO,'(1X,A,3E12.3)') 'energy                  ',ECMP,PVIRTP
8565         WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
8566      &       XM1,XM2,XM3,XM4
8567         WRITE(LO,'(A)') ' input cross sections (millibarn):'
8568         WRITE(LO,'(A,2E12.3)') '           SIGR     ',SIGR
8569         WRITE(LO,'(A,2E12.3)') ' (soft)    SIGP     ',SIGP
8570         WRITE(LO,'(A,2E12.3)') ' (hard)    SIGHR    ',SIGHR
8571         WRITE(LO,'(A,2E12.3)') '           SIGHD    ',SIGHD
8572         WRITE(LO,'(A,4E12.3)') '           SIGT1    ',SIGT1
8573         WRITE(LO,'(A,4E12.3)') '           SIGT2    ',SIGT2
8574         WRITE(LO,'(A,2E12.3)') '           SIGL     ',SIGL
8575         WRITE(LO,'(A,4E12.3)') '         SIGDP(1-2) ',SIGDP(1),SIGDP(2)
8576         WRITE(LO,'(A,4E12.3)') '         SIGDP(3-4) ',SIGDP(3),SIGDP(4)
8577         WRITE(LO,'(A)') ' input slopes (GeV**-2)'
8578         WRITE(LO,'(A,2E12.3)') '           BREG     ',BREG
8579         WRITE(LO,'(A,2E12.3)') '            BREG1   ',BREG1
8580         WRITE(LO,'(A,2E12.3)') '            BREG2   ',BREG2
8581         WRITE(LO,'(A,2E12.3)') '           BPOM     ',BPOM
8582         WRITE(LO,'(A,2E12.3)') '            BPOM1   ',BPOM1
8583         WRITE(LO,'(A,2E12.3)') '            BPOM2   ',BPOM2
8584         WRITE(LO,'(A,2E12.3)') '           BHAR     ',BHAR
8585         WRITE(LO,'(A,2E12.3)') '           BHAD     ',BHAD
8586         WRITE(LO,'(A,E12.3)')  '           B0PPP    ',B0PPP
8587         WRITE(LO,'(A,4E12.3)') '           BTR1     ',BTR1
8588         WRITE(LO,'(A,4E12.3)') '           BTR2     ',BTR2
8589         WRITE(LO,'(A,2E12.3)') '           BLOO     ',BLOO
8590         WRITE(LO,'(A,4E12.3)') '           BDP(1-2) ',BDP(1),BDP(2)
8591         WRITE(LO,'(A,4E12.3)') '           BDP(3-4) ',BDP(3),BDP(4)
8592       ENDIF
8593 C
8594       BPOM  = BPOM*GEV2MB
8595       BREG  = BREG*GEV2MB
8596       BHAR  = BHAR*GEV2MB
8597       BHAD  = BHAD*GEV2MB
8598       BTR1(1)  = BTR1(1)*GEV2MB
8599       BTR1(2)  = BTR1(2)*GEV2MB
8600       BTR2(1)  = BTR2(1)*GEV2MB
8601       BTR2(2)  = BTR2(2)*GEV2MB
8602       BLOO  = BLOO*GEV2MB
8603 C
8604       BP4 =BPOM*4.D0
8605       BR4 =BREG*4.D0
8606       BHR4=BHAR*4.D0
8607       BHD4=BHAD*4.D0
8608       BT14(1)=BTR1(1)*4.D0
8609       BT14(2)=BTR1(2)*4.D0
8610       BT24(1)=BTR2(1)*4.D0
8611       BT24(2)=BTR2(2)*4.D0
8612       BL4 =BLOO*4.D0
8613 C
8614       ZIGP     = SIGP/(PI2*BP4)
8615       ZIGR     = SIGR/(PI2*BR4)
8616       ZIGHR    = SIGHR/(PI2*BHR4)
8617       ZIGHD    = SIGHD/(PI2*BHD4)
8618       ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
8619       ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
8620       ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
8621       ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
8622       ZIGL = SIGL/(PI2*BL4)
8623       DO 20 I=1,4
8624         BDP(I) = BDP(I)*GEV2MB
8625         BD4(I) = BDP(I)*4.D0
8626         ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
8627  20   CONTINUE
8628 C
8629       IF(IDEB(48).GE.10) THEN
8630         WRITE(LO,'(A)') ' normalized input values:'
8631         WRITE(LO,'(A,2E12.3)') '           ZIGR ',ZIGR
8632         WRITE(LO,'(A,2E12.3)') '           BREG ',BREG
8633         WRITE(LO,'(A,2E12.3)') '           ZIGP ',ZIGP
8634         WRITE(LO,'(A,2E12.3)') '           BPOM ',BPOM
8635         WRITE(LO,'(A,2E12.3)') '          ZIGHR ',ZIGHR
8636         WRITE(LO,'(A,2E12.3)') '           BHAR ',BHAR
8637         WRITE(LO,'(A,2E12.3)') '          ZIGHD ',ZIGHD
8638         WRITE(LO,'(A,2E12.3)') '           BHAD ',BHAD
8639         WRITE(LO,'(A,4E12.3)') '          ZIGT1 ',ZIGT1
8640         WRITE(LO,'(A,4E12.3)') '          ZIGT2 ',ZIGT2
8641         WRITE(LO,'(A,2E12.3)') '           ZIGL ',ZIGL
8642         WRITE(LO,'(A,4E12.3)') '     ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
8643         WRITE(LO,'(A,4E12.3)') '     ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
8644       ENDIF
8645       END
8646
8647 *$ CREATE PHO_SCALES.FOR
8648 *COPY PHO_SCALES
8649 CDECK  ID>, PHO_SCALES
8650       SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
8651 C**********************************************************************
8652 C
8653 C     calculation of scale factors
8654 C              (mass dependent couplings and slopes)
8655 C
8656 C     input:   XM1..XM4     external masses
8657 C
8658 C     output:  SCG1,SCG2    scales of coupling constants
8659 C              SCB1,SCB2    scales of coupling slope parameter
8660 C
8661 C*********************************************************************
8662       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8663       SAVE
8664
8665       PARAMETER ( EPS  = 1.D-3 )
8666
8667 C  input/output channels
8668       INTEGER LI,LO
8669       COMMON /POINOU/ LI,LO
8670 C  event debugging information
8671       INTEGER NMAXD
8672       PARAMETER (NMAXD=100)
8673       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8674      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8675       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8676      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8677 C  Reggeon phenomenology parameters
8678       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8679      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8680       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8681      &                ALREG,ALREGP,GR(2),B0REG(2),
8682      &                GPPP,GPPR,B0PPP,B0PPR,
8683      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8684 C  parameters of 2x2 channel model
8685       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8686       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8687 C  data of c.m. system of Pomeron / Reggeon exchange
8688       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8689       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8690      &                 SIDP,CODP,SIFP,COFP
8691       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8692      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
8693      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
8694 C  model switches and parameters
8695       CHARACTER*8 MDLNA
8696       INTEGER ISWMDL,IPAMDL
8697       DOUBLE PRECISION PARMDL
8698       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8699
8700 C  scale factors for couplings
8701       ECMMIN = 2.D0
8702 *     ECMTP = 6.D0
8703       ECMTP = 1.D0
8704       IF(ABS(XM1-XM3).GT.EPS) THEN
8705         IF(ECMP.LT.ECMTP) THEN
8706           SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8707         ELSE
8708           SCG1 = PHISUP(1)
8709         ENDIF
8710       ELSE
8711         SCG1 = 1.D0
8712       ENDIF
8713       IF(ABS(XM2-XM4).GT.EPS) THEN
8714         IF(ECMP.LT.ECMTP) THEN
8715           SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8716         ELSE
8717           SCG2 = PHISUP(2)
8718         ENDIF
8719       ELSE
8720         SCG2 = 1.D0
8721       ENDIF
8722 C
8723 C  scale factors for slope parameters
8724       IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
8725         SCB1 = 1.D0
8726         SCB2 = 1.D0
8727       ELSE IF(ISWMDL(1).EQ.2) THEN
8728 C  rational
8729         SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
8730         SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
8731       ELSE IF(ISWMDL(1).GE.3) THEN
8732 C  symmetric gaussian
8733         SCB1 = VAR*(XM1-XM3)**2
8734         IF(SCB1.LT.25.D0) THEN
8735           SCB1 = EXP(-SCB1)
8736         ELSE
8737           SCB1 = 0.D0
8738         ENDIF
8739         SCB2 = VAR*(XM2-XM4)**2
8740         IF(SCB2.LT.25.D0) THEN
8741           SCB2 = EXP(-SCB2)
8742         ELSE
8743           SCB2 = 0.D0
8744         ENDIF
8745       ELSE
8746         WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
8747      &    ISWMDL(1)
8748         CALL PHO_ABORT
8749       ENDIF
8750 C  debug output
8751       IF(IDEB(65).GE.10) THEN
8752         WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
8753      &       XM1,XM2,XM3,XM4
8754         WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
8755      &       SCB1,SCB2,SCG1,SCG2
8756       ENDIF
8757       END
8758
8759 *$ CREATE PHO_EIKON.FOR
8760 *COPY PHO_EIKON
8761 CDECK  ID>, PHO_EIKON
8762       SUBROUTINE PHO_EIKON(IP,IFHARD,B)
8763 C*********************************************************************
8764 C
8765 C     calculation of unitarized amplitudes
8766 C
8767 C     input: IP               particle combination
8768 C            IFHARD           -1  ignore previously calculated Born
8769 C                                 cross sections
8770 C                             0   calculate hard Born cross sections or
8771 C                                 take them from interpolation table
8772 C                                 (if available)
8773 C                             1   take hard cross sections from /POSBRN/
8774 C            B                impact parameter (mb**(1/2))
8775 C                   /POSBRN/  input cross sections
8776 C                   /GLOCMS/  cm energy
8777 C                   /POPREG/  soft and hard parameters
8778 C
8779 C     output: /POINT4/
8780 C             AMPEL           purely elastic amplitude
8781 C             AMPVM           quasi-elastically vectormeson prod.
8782 C             AMLMSD(2)       amplitudes of low mass sing. diffr.
8783 C             AMHMSD(2)       amplitudes of high mass sing. diffr.
8784 C             AMLMDD          amplitude of low mass double diffr.
8785 C             AMHMDD          amplitude of high mass double diffr.
8786 C
8787 C*********************************************************************
8788       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8789       SAVE
8790
8791       PARAMETER(ITWO=2,
8792      &        ITHREE=3,
8793      &         IFOUR=4,
8794      &         IFIVE=5,
8795      &          ISIX=6,
8796      &          FIVE=5.D0,
8797      &         THOUS=1.D3,
8798      &        EXPMAX=70.D0,
8799      &          DEPS=1.D-20)
8800
8801 C  input/output channels
8802       INTEGER LI,LO
8803       COMMON /POINOU/ LI,LO
8804 C  event debugging information
8805       INTEGER NMAXD
8806       PARAMETER (NMAXD=100)
8807       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8808      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8809       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8810      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8811 C  complex Born graph amplitudes used for unitarization
8812       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
8813      &                AMHMDD,AMPDP
8814       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
8815      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
8816 C  cross sections
8817       INTEGER IPFIL,IFAFIL,IFBFIL
8818       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
8819      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
8820      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
8821      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
8822      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
8823       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
8824      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
8825      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
8826      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
8827      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
8828      &                IPFIL,IFAFIL,IFBFIL
8829 C  Born graph cross sections and slopes
8830       INTEGER Max_pro_3
8831       PARAMETER ( Max_pro_3 = 16 )
8832       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8833      &                SIGD1,SIGD2,DSIGH
8834       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8835      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8836 C  scaled cross sections and slopes
8837       COMPLEX*16      ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8838      &                ZIGD1,ZIGD2,
8839      &                BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8840       COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8841      &                ZIGDP(4),ZIGD1(2),ZIGD2(2),
8842      &                BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8843      &                BD1(2),BD2(2)
8844 C  Born graph cross sections after applying diffraction model
8845       DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
8846      &                 SBOLPO,SBODPO
8847       COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
8848      &                SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
8849      &                SBODPO(0:4,4)
8850 C  global event kinematics and particle IDs
8851       INTEGER IFPAP,IFPAB
8852       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
8853       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
8854 C  data of c.m. system of Pomeron / Reggeon exchange
8855       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8856       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8857      &                 SIDP,CODP,SIFP,COFP
8858       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8859      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
8860      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
8861 C  Reggeon phenomenology parameters
8862       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8863      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8864       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8865      &                ALREG,ALREGP,GR(2),B0REG(2),
8866      &                GPPP,GPPR,B0PPP,B0PPR,
8867      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8868 C  parameters of 2x2 channel model
8869       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8870       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8871 C  model switches and parameters
8872       CHARACTER*8 MDLNA
8873       INTEGER ISWMDL,IPAMDL
8874       DOUBLE PRECISION PARMDL
8875       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8876 C  unitarized amplitudes for different diffraction channels
8877       DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
8878      &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
8879      &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
8880      &                 ZXL,BXL
8881       COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
8882      &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
8883      &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
8884      &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
8885      &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
8886      &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
8887      &                ZXL(4,4),BXL(4,4)
8888
8889       COMPLEX*16      CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
8890      &                AUXL,AMPR,AMPO,AMPP,AMPQ
8891
8892       DIMENSION PVOLD(2)
8893
8894       DATA  ELAST / 0.D0 /
8895       DATA  IPOLD / -1 /
8896       DATA  PVOLD / -1.D0, -1.D0 /
8897       DATA  XMPOM / 0.766D0 /
8898       DATA  XMVDM / 0.766D0 /
8899
8900       DCMPLX(X,Y) = CMPLX(X,Y)
8901
8902 C  calculation of scaled cross sections and slopes
8903
8904 C  test for redundant calculation
8905       IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
8906      &   .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
8907 C  effective particle masses, VDM assumption
8908         XMASS1 = PMASS(1)
8909         XMASS2 = PMASS(2)
8910         RMASS1 = RMASS(1)
8911         RMASS2 = RMASS(2)
8912         IF(IFPAP(1).EQ.22) THEN
8913           XMASS1 = XMVDM
8914         ELSE IF(IFPAP(1).EQ.990) THEN
8915           XMASS1 = XMPOM
8916         ENDIF
8917         IF(IFPAP(2).EQ.22) THEN
8918           XMASS2 = XMVDM
8919         ELSE IF(IFPAP(2).EQ.990) THEN
8920           XMASS2 = XMPOM
8921         ENDIF
8922 C  different particle combinations
8923         IF(IP.EQ.3) THEN
8924           XMASS1 = XMASS2
8925           RMASS1 = RMASS2
8926         ELSE IF(IP.EQ.4) THEN
8927           XMASS1 = XMPOM
8928           RMASS1 = XMASS1
8929         ENDIF
8930         IF(IP.GT.1) THEN
8931           XMASS2 = XMPOM
8932           RMASS2 = XMASS2
8933         ENDIF
8934 C  update pomeron CM system
8935         PMASSP(1) = XMASS1
8936         PMASSP(2) = XMASS2
8937         ECMP = ECM
8938
8939         CZERO    = DCMPLX(0.D0,0.D0)
8940         CONE     = DCMPLX(1.D0,0.D0)
8941         ELAST    = ECM
8942         PVOLD(1) = PVIRT(1)
8943         PVOLD(2) = PVIRT(2)
8944         IPOLD    = IP
8945
8946 C  purely elastic scattering
8947         CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
8948           ZXP(1,1) = ZIGP
8949           BXP(1,1) = BPOM
8950           ZXR(1,1) = ZIGR
8951           BXR(1,1) = BREG
8952           ZXH(1,1) = ZIGHR
8953           BXH(1,1) = BHAR
8954           ZXD(1,1) = ZIGHD
8955           BXD(1,1) = BHAD
8956           ZXT1A(1,1) = ZIGT1(1)
8957           BXT1A(1,1) = BTR1(1)
8958           ZXT1B(1,1) = ZIGT1(2)
8959           BXT1B(1,1) = BTR1(2)
8960           ZXT2A(1,1) = ZIGT2(1)
8961           BXT2A(1,1) = BTR2(1)
8962           ZXT2B(1,1) = ZIGT2(2)
8963           BXT2B(1,1) = BTR2(2)
8964           ZXL(1,1) = ZIGL
8965           BXL(1,1) = BLOO
8966           ZXDPE(1,1) = ZIGDP(1)
8967           BXDPE(1,1) = BDP(1)
8968           ZXDPA(1,1) = ZIGDP(2)
8969           BXDPA(1,1) = BDP(2)
8970           ZXDPB(1,1) = ZIGDP(3)
8971           BXDPB(1,1) = BDP(3)
8972           ZXDPD(1,1) = ZIGDP(4)
8973           BXDPD(1,1) = BDP(4)
8974           SBOPOM(1) = SIGP
8975           SBOREG(1) = SIGR
8976           SBOHAR(1) = SIGHR
8977           SBOHAD(1) = SIGHD
8978           SBOTR1(1,1) = SIGT1(1)
8979           SBOTR1(1,2) = SIGT1(2)
8980           SBOTR2(1,1) = SIGT2(1)
8981           SBOTR2(1,2) = SIGT2(2)
8982           SBOLPO(1) = SIGL
8983           SBODPO(1,1) = SIGDP(1)
8984           SBODPO(1,2) = SIGDP(2)
8985           SBODPO(1,3) = SIGDP(3)
8986           SBODPO(1,4) = SIGDP(4)
8987
8988 C  low mass single diffractive scattering 1
8989         CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
8990           ZXP(1,2) = ZIGP
8991           BXP(1,2) = BPOM
8992           ZXR(1,2) = ZIGR
8993           BXR(1,2) = BREG
8994           ZXH(1,2) = ZIGHR
8995           BXH(1,2) = BHAR
8996           ZXD(1,2) = ZIGHD
8997           BXD(1,2) = BHAD
8998           ZXT1A(1,2) = ZIGT1(1)
8999           BXT1A(1,2) = BTR1(1)
9000           ZXT1B(1,2) = ZIGT1(2)
9001           BXT1B(1,2) = BTR1(2)
9002           ZXT2A(1,2) = ZIGT2(1)
9003           BXT2A(1,2) = BTR2(1)
9004           ZXT2B(1,2) = ZIGT2(2)
9005           BXT2B(1,2) = BTR2(2)
9006           ZXL(1,2) = ZIGL
9007           BXL(1,2) = BLOO
9008           ZXDPE(1,2) = ZIGDP(1)
9009           BXDPE(1,2) = BDP(1)
9010           ZXDPA(1,2) = ZIGDP(2)
9011           BXDPA(1,2) = BDP(2)
9012           ZXDPB(1,2) = ZIGDP(3)
9013           BXDPB(1,2) = BDP(3)
9014           ZXDPD(1,2) = ZIGDP(4)
9015           BXDPD(1,2) = BDP(4)
9016           SBOPOM(2) = SIGP
9017           SBOREG(2) = SIGR
9018           SBOHAR(2) = SIGHR
9019           SBOHAD(2) = 0.D0
9020           SBOTR1(2,1) = SIGT1(1)
9021           SBOTR1(2,2) = SIGT1(2)
9022           SBOTR2(2,1) = SIGT2(1)
9023           SBOTR2(2,2) = SIGT2(2)
9024           SBOLPO(2) = SIGL
9025           SBODPO(2,1) = SIGDP(1)
9026           SBODPO(2,2) = SIGDP(2)
9027           SBODPO(2,3) = SIGDP(3)
9028           SBODPO(2,4) = SIGDP(4)
9029
9030 C  low mass single diffractive scattering 2
9031         CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
9032           ZXP(1,3) = ZIGP
9033           BXP(1,3) = BPOM
9034           ZXR(1,3) = ZIGR
9035           BXR(1,3) = BREG
9036           ZXH(1,3) = ZIGHR
9037           BXH(1,3) = BHAR
9038           ZXD(1,3) = ZIGHD
9039           BXD(1,3) = BHAD
9040           ZXT1A(1,3) = ZIGT1(1)
9041           BXT1A(1,3) = BTR1(1)
9042           ZXT1B(1,3) = ZIGT1(2)
9043           BXT1B(1,3) = BTR1(2)
9044           ZXT2A(1,3) = ZIGT2(1)
9045           BXT2A(1,3) = BTR2(1)
9046           ZXT2B(1,3) = ZIGT2(2)
9047           BXT2B(1,3) = BTR2(2)
9048           ZXL(1,3) = ZIGL
9049           BXL(1,3) = BLOO
9050           ZXDPE(1,3) = ZIGDP(1)
9051           BXDPE(1,3) = BDP(1)
9052           ZXDPA(1,3) = ZIGDP(2)
9053           BXDPA(1,3) = BDP(2)
9054           ZXDPB(1,3) = ZIGDP(3)
9055           BXDPB(1,3) = BDP(3)
9056           ZXDPD(1,3) = ZIGDP(4)
9057           BXDPD(1,3) = BDP(4)
9058           SBOPOM(3) = SIGP
9059           SBOREG(3) = SIGR
9060           SBOHAR(3) = SIGHR
9061           SBOHAD(3) = 0.D0
9062           SBOTR1(3,1) = SIGT1(1)
9063           SBOTR1(3,2) = SIGT1(2)
9064           SBOTR2(3,1) = SIGT2(1)
9065           SBOTR2(3,2) = SIGT2(2)
9066           SBOLPO(3) = SIGL
9067           SBODPO(3,1) = SIGDP(1)
9068           SBODPO(3,2) = SIGDP(2)
9069           SBODPO(3,3) = SIGDP(3)
9070           SBODPO(3,4) = SIGDP(4)
9071
9072 C  low mass double diffractive scattering
9073         CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
9074           ZXP(1,4) = ZIGP
9075           BXP(1,4) = BPOM
9076           ZXR(1,4) = ZIGR
9077           BXR(1,4) = BREG
9078           ZXH(1,4) = ZIGHR
9079           BXH(1,4) = BHAR
9080           ZXD(1,4) = ZIGHD
9081           BXD(1,4) = BHAD
9082           ZXT1A(1,4) = ZIGT1(1)
9083           BXT1A(1,4) = BTR1(1)
9084           ZXT1B(1,4) = ZIGT1(2)
9085           BXT1B(1,4) = BTR1(2)
9086           ZXT2A(1,4) = ZIGT2(1)
9087           BXT2A(1,4) = BTR2(1)
9088           ZXT2B(1,4) = ZIGT2(2)
9089           BXT2B(1,4) = BTR2(2)
9090           ZXL(1,4) = ZIGL
9091           BXL(1,4) = BLOO
9092           ZXDPE(1,4) = ZIGDP(1)
9093           BXDPE(1,4) = BDP(1)
9094           ZXDPA(1,4) = ZIGDP(2)
9095           BXDPA(1,4) = BDP(2)
9096           ZXDPB(1,4) = ZIGDP(3)
9097           BXDPB(1,4) = BDP(3)
9098           ZXDPD(1,4) = ZIGDP(4)
9099           BXDPD(1,4) = BDP(4)
9100           SBOPOM(4) = SIGP
9101           SBOREG(4) = SIGR
9102           SBOHAR(4) = SIGHR
9103           SBOHAD(4) = 0.D0
9104           SBOTR1(4,1) = SIGT1(1)
9105           SBOTR1(4,2) = SIGT1(2)
9106           SBOTR2(4,1) = SIGT2(1)
9107           SBOTR2(4,2) = SIGT2(2)
9108           SBOLPO(4) = SIGL
9109           SBODPO(4,1) = SIGDP(1)
9110           SBODPO(4,2) = SIGDP(2)
9111           SBODPO(4,3) = SIGDP(3)
9112           SBODPO(4,4) = SIGDP(4)
9113
9114 C  calculate Born graph cross sections
9115         SBOPOM(0) = 0.D0
9116         SBOREG(0) = 0.D0
9117         SBOHAR(0) = 0.D0
9118         SBOHAD(0) = 0.D0
9119         SBOTR1(0,1) = 0.D0
9120         SBOTR1(0,2) = 0.D0
9121         SBOTR2(0,1) = 0.D0
9122         SBOTR2(0,2) = 0.D0
9123         SBOLPO(0) = 0.D0
9124         SBODPO(0,1) = 0.D0
9125         SBODPO(0,2) = 0.D0
9126         SBODPO(0,3) = 0.D0
9127         SBODPO(0,4) = 0.D0
9128         DO 150 I=1,4
9129           SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
9130           SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
9131           SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
9132           SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
9133           SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
9134           SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
9135           SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
9136           SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
9137           SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
9138           SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
9139           SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
9140           SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
9141           SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
9142  150    CONTINUE
9143
9144         SIGPOM = SBOPOM(0)
9145         SIGREG = SBOREG(0)
9146         SIGTR1(1) = SBOTR1(0,1)
9147         SIGTR1(2) = SBOTR1(0,2)
9148         SIGTR2(1) = SBOTR2(0,1)
9149         SIGTR2(2) = SBOTR2(0,2)
9150         SIGLOO = SBOLPO(0)
9151         SIGDPO(1) = SBODPO(0,1)
9152         SIGDPO(2) = SBODPO(0,2)
9153         SIGDPO(3) = SBODPO(0,3)
9154         SIGDPO(4) = SBODPO(0,4)
9155         SIGHAR = SBOHAR(0)
9156         SIGDIR = SBOHAD(0)
9157       ENDIF
9158
9159       B24=DCMPLX(B**2,0.D0)/4.D0
9160
9161       AMPEL     = CZERO
9162       AMPR      = CZERO
9163       AMPO      = CZERO
9164       AMPP      = CZERO
9165       AMPQ      = CZERO
9166       AMLMSD(1) = CZERO
9167       AMLMSD(2) = CZERO
9168       AMHMSD(1) = CZERO
9169       AMHMSD(2) = CZERO
9170       AMLMDD    = CZERO
9171       AMHMDD    = CZERO
9172
9173 C  different models
9174
9175       IF(ISWMDL(1).LT.3) THEN
9176 C  pomeron
9177         AUXP  = ZXP(1,1)*EXP(-B24/BXP(1,1))
9178 C  reggeon
9179         AUXR  = ZXR(1,1)*EXP(-B24/BXR(1,1))
9180 C  hard resolved processes
9181         AUXH  = ZXH(1,1)*EXP(-B24/BXH(1,1))
9182 C  hard direct processes
9183         AUXD  = ZXD(1,1)*EXP(-B24/BXD(1,1))
9184 C  triple-Pomeron: baryon high mass diffraction
9185         AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
9186      &        + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
9187 C  triple-Pomeron: photon/meson high mass diffraction
9188         AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
9189      &        + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
9190 C  loop-Pomeron
9191         AUXL  = ZXL(1,1)*EXP(-B24/BXL(1,1))
9192       ENDIF
9193
9194       IF(ISWMDL(1).EQ.0) THEN
9195         AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
9196      &                 *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
9197      &        +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
9198      &               )
9199         AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
9200      &                                      +AUXT1+AUXT2+AUXL))
9201         AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
9202      &                                      +AUXT1+AUXT2+AUXL))
9203         AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
9204      &                                      +AUXT1+AUXT2+AUXL))
9205         AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
9206      &                                      +AUXT1+AUXT2+AUXL))
9207
9208       ELSE IF(ISWMDL(1).EQ.1) THEN
9209         AMPR = 0.5D0*SQRT(VDMQ2F(1))*
9210      &         ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
9211         AMPO = 0.5D0*SQRT(VDMQ2F(2))*
9212      &         ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
9213         AMPP = 0.5D0*SQRT(VDMQ2F(3))*
9214      &         ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
9215         AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
9216      &         ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
9217         AMPEL = SQRT(VDMQ2F(1))*AMPR
9218      &         + SQRT(VDMQ2F(2))*AMPO
9219      &         + SQRT(VDMQ2F(3))*AMPP
9220      &         + SQRT(VDMQ2F(4))*AMPQ
9221      &         + AUXD/2.D0
9222
9223 C  simple analytic two channel model (version A)
9224       ELSE IF(ISWMDL(1).EQ.3) THEN
9225         CALL PHO_CHAN2A(B)
9226
9227       ELSE
9228         WRITE(LO,'(1X,A,I2)')
9229      &       'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
9230         STOP
9231       ENDIF
9232
9233       END
9234
9235 *$ CREATE PHO_DSIGDT.FOR
9236 *COPY PHO_DSIGDT
9237 CDECK  ID>, PHO_DSIGDT
9238       SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
9239 C*********************************************************************
9240 C
9241 C     calculation of unitarized amplitude
9242 C                    and differential cross section
9243 C
9244 C     input:   EE       cm energy (GeV)
9245 C              XTA(1,*) t values (GeV**2)
9246 C              NFILL    entries in t table
9247 C
9248 C     output:  XTA(2,*)  DSIG/DT  g p --> g h/V (mub/GeV**2)
9249 C              XTA(3,*)  DSIG/DT  g p --> rho0 h/V
9250 C              XTA(4,*)  DSIG/DT  g p --> omega0 h/V
9251 C              XTA(5,*)  DSIG/DT  g p --> phi h/V
9252 C              XTA(6,*)  DSIG/DT  g p --> pi+ pi- h/V (continuum)
9253 C
9254 C*********************************************************************
9255       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9256       SAVE
9257
9258       PARAMETER(ITWO=2,
9259      &        ITHREE=3,
9260      &         THOUS=1.D3,
9261      &          DEPS=1.D-20)
9262
9263       DIMENSION XTA(6,NFILL)
9264
9265 C  input/output channels
9266       INTEGER LI,LO
9267       COMMON /POINOU/ LI,LO
9268 C  some constants
9269       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9270       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9271      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9272 C  integration precision for hard cross sections (obsolete)
9273       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9274       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9275 C  event debugging information
9276       INTEGER NMAXD
9277       PARAMETER (NMAXD=100)
9278       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9279      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9280       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9281      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9282 C  global event kinematics and particle IDs
9283       INTEGER IFPAP,IFPAB
9284       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9285       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9286 C  complex Born graph amplitudes used for unitarization
9287       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9288      &                AMHMDD,AMPDP
9289       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9290      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9291
9292       COMPLEX*16   XT,AMP,CZERO
9293       DIMENSION    AMP(5),XPNT(96),WGHT(96),XT(5,100)
9294       CHARACTER*12 FNA
9295
9296       CDABS(AMPEL) = ABS(AMPEL)
9297       DCMPLX(X,Y) = CMPLX(X,Y)
9298
9299       CZERO=DCMPLX(0.D0,0.D0)
9300
9301       ETMP = ECM
9302       ECM  = EE
9303
9304       IF(NFILL.GT.100) THEN
9305         WRITE(LO,'(1X,A,I4)')
9306      &    'PHO_DSIGDT:ERROR: too many entries in table',NFILL
9307         STOP
9308       ENDIF
9309 C
9310       DO 100 K=1,NFILL
9311         DO 150 L=1,5
9312           XT(L,K)=CZERO
9313  150    CONTINUE
9314  100  CONTINUE
9315 C
9316 C  impact parameter integration
9317 C     BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9318       BMAX=10.D0
9319       CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9320       IAMP = 5
9321       IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
9322         I1 = 1
9323         I2 = 0
9324       ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
9325         I1 = 0
9326         I2 = 1
9327       ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
9328         I1 = 1
9329         I2 = 1
9330       ELSE
9331         I1 = 0
9332         I2 = 0
9333         IAMP = 1
9334       ENDIF
9335       J1 = I1*2
9336       K1 = I1*3
9337       L1 = I1*4
9338       J2 = I2*2
9339       K2 = I2*3
9340       L2 = I2*4
9341 C
9342       DO 200 I=1,NGAUSO
9343         WG=WGHT(I)*XPNT(I)
9344 C  calculate amplitudes
9345         IF(I.EQ.1) THEN
9346           CALL PHO_EIKON(1,-1,XPNT(I))
9347         ELSE
9348           CALL PHO_EIKON(1,1,XPNT(I))
9349         ENDIF
9350         AMP(1) = AMPEL
9351         AMP(2) = AMPVM(I1,I2)
9352         AMP(3) = AMPVM(J1,J2)
9353         AMP(4) = AMPVM(K1,K2)
9354         AMP(5) = AMPVM(L1,L2)
9355 C
9356         DO 400 J=1,NFILL
9357           XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
9358           FAC = PHO_BESSJ0(XX)*WG
9359           DO 500 K=1,IAMP
9360             XT(1,J)=XT(1,J)+AMP(K)*FAC
9361  500      CONTINUE
9362  400    CONTINUE
9363  200  CONTINUE
9364 C
9365 C  change units to mb/GeV**2
9366       FAC = 4.D0*PI/GEV2MB
9367       FNA = '(mb/GeV**2) '
9368       IF(I1+I2.EQ.1) THEN
9369         FAC = FAC*THOUS
9370         FNA = '(mub/GeV**2)'
9371       ELSE IF(I1+I2.EQ.2) THEN
9372         FAC = FAC*THOUS*THOUS
9373         FNA = '(nb/GeV**2) '
9374       ENDIF
9375       IF(IDEB(56).GE.5) THEN
9376         WRITE(LO,'(1X,A,A12,/1X,A)') 'table:  -T (GeV**2)   DSIG/DT ',
9377      &    FNA,'------------------------------------------'
9378       ENDIF
9379       DO 600 J=1,NFILL
9380         DO 700 K=1,IAMP
9381           XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
9382  700    CONTINUE
9383         IF(IDEB(56).GE.5) THEN
9384           WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
9385         ENDIF
9386  600  CONTINUE
9387
9388       ECM = ETMP
9389       END
9390
9391 *$ CREATE PHO_XSECT.FOR
9392 *COPY PHO_XSECT
9393 CDECK  ID>, PHO_XSECT
9394       SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
9395 C*********************************************************************
9396 C
9397 C     calculation of physical cross sections
9398 C
9399 C     input:   IP      particle combination
9400 C              IFHARD  -1 reset Born graph cross section tables
9401 C                      0  calculate hard cross sections or take them
9402 C                         from interpolation table (if available)
9403 C                      1  assume that hard cross sections are already
9404 C                         calculated and stored in /POSBRN/
9405 C              EE      cms energy (GeV)
9406 C
9407 C     output:  /POSBRN/  input cross sections
9408 C              /POZBRN/  scaled input cross values
9409 C              /POCSEC/  physical cross sections and slopes
9410 C
9411 C              slopes in GeV**-2, cross sections in mb
9412 C
9413 C*********************************************************************
9414       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9415       SAVE
9416
9417       PARAMETER(ONEM=-1.D0,
9418      &         THOUS=1.D3,
9419      &          DEPS=1.D-20)
9420
9421 C  input/output channels
9422       INTEGER LI,LO
9423       COMMON /POINOU/ LI,LO
9424 C  some constants
9425       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9426       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9427      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9428 C  event debugging information
9429       INTEGER NMAXD
9430       PARAMETER (NMAXD=100)
9431       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9432      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9433       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9434      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9435 C  integration precision for hard cross sections (obsolete)
9436       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9437       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9438 C  model switches and parameters
9439       CHARACTER*8 MDLNA
9440       INTEGER ISWMDL,IPAMDL
9441       DOUBLE PRECISION PARMDL
9442       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9443 C  Born graph cross sections and slopes
9444       INTEGER Max_pro_3
9445       PARAMETER ( Max_pro_3 = 16 )
9446       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9447      &                SIGD1,SIGD2,DSIGH
9448       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9449      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9450 C  cross sections
9451       INTEGER IPFIL,IFAFIL,IFBFIL
9452       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9453      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9454      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9455      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9456      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9457       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9458      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9459      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9460      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9461      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9462      &                IPFIL,IFAFIL,IFBFIL
9463 C  global event kinematics and particle IDs
9464       INTEGER IFPAP,IFPAB
9465       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9466       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9467
9468       CHARACTER*15    PHO_PNAME
9469
9470 C  complex Born graph amplitudes used for unitarization
9471       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9472      &                AMHMDD,AMPDP
9473       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9474      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9475
9476       DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
9477       CHARACTER*8 VMESA(0:4),VMESB(0:4)
9478       DATA VMESA / 'vmeson  ','rho     ','omega   ','phi     ',
9479      &             'pi+pi-  ' /
9480       DATA VMESB / 'vmeson  ','rho     ','omega   ','phi     ',
9481      &             'pi+pi-  ' /
9482
9483       CDABS(AMPEL) = ABS(AMPEL)
9484
9485       ETMP = ECM
9486       IF(EE.LT.0.D0) GOTO 500
9487       ECM = EE
9488
9489 C  impact parameter integration
9490 C     BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9491       BMAX=10.D0
9492       CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9493       SIGTOT    = 0.D0
9494       SIGINE    = 0.D0
9495       SIGELA    = 0.D0
9496       SIGNDF    = 0.D0
9497       SIGLSD(1) = 0.D0
9498       SIGLSD(2) = 0.D0
9499       SIGLDD    = 0.D0
9500       SIGHSD(1) = 0.D0
9501       SIGHSD(2) = 0.D0
9502       SIGHDD    = 0.D0
9503       SIGCDF(0) = 0.D0
9504       SIG1SO    = 0.D0
9505       SIG1HA    = 0.D0
9506       SLEL1 = 0.D0
9507       SLEL2 = 0.D0
9508       DO 50 I=1,4
9509         SIGCDF(I) = 0.D0
9510         DO 55 K=1,4
9511           SIGVM(I,K) = 0.D0
9512           SLVM1(I,K) = 0.D0
9513           SLVM2(I,K) = 0.D0
9514  55     CONTINUE
9515  50   CONTINUE
9516
9517       DO 100 I=1,NGAUSO
9518         B2  = XPNT(I)**2
9519         WG  = WGHT(I)*XPNT(I)
9520         WGB = B2*WG
9521
9522 C  calculate impact parameter amplitude, results in /POINT4/
9523         IF(I.EQ.1) THEN
9524           CALL PHO_EIKON(IP,IFHARD,XPNT(I))
9525         ELSE
9526           CALL PHO_EIKON(IP,1,XPNT(I))
9527         ENDIF
9528
9529         SIGTOT    = SIGTOT + DREAL(AMPEL)*WG
9530         SIGELA    = SIGELA + CDABS(AMPEL)**2*WG
9531         SLEL1     = SLEL1  + AMPEL*WGB
9532         SLEL2     = SLEL2  + AMPEL*WG
9533
9534         DO 110 J=1,4
9535           DO 120 K=1,4
9536             SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
9537             SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
9538             SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
9539  120      CONTINUE
9540           SIGCDF(J)   = SIGCDF(J)   + DREAL(AMPDP(J))*WG
9541  110    CONTINUE
9542
9543         SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
9544         SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
9545         SIGLDD    = SIGLDD    + CDABS(AMLMDD)**2*WG
9546         SIG1SO    = SIG1SO    + DREAL(AMPSOF)*WG
9547         SIG1HA    = SIG1HA    + DREAL(AMPHAR)*WG
9548         SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
9549         SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
9550         SIGHDD    = SIGHDD    + DREAL(AMHMDD)*WG
9551
9552  100  CONTINUE
9553
9554       SIGDIR = DREAL(SIGHD)
9555       FAC    = 4.D0*PI2
9556       SIGTOT = SIGTOT*FAC
9557       SIGELA = SIGELA*FAC
9558       FACSL  = 0.5D0/GEV2MB
9559       SLOEL  = SLEL1/MAX(DEPS,SLEL2)*FACSL
9560
9561       IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
9562         DO 130 I=1,4
9563           DO 140 J=1,4
9564             SIGVM(I,J) = SIGVM(I,J)*FAC
9565             SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
9566  140      CONTINUE
9567  130    CONTINUE
9568         SIGVM(0,0) = 0.D0
9569         DO 150 I=1,4
9570           SIGVM(0,I) = 0.D0
9571           SIGVM(I,0) = 0.D0
9572           DO 160 J=1,4
9573             SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
9574             SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
9575  160      CONTINUE
9576           SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
9577  150    CONTINUE
9578       ENDIF
9579
9580 C  diffractive cross sections
9581
9582       SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
9583       SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
9584       SIGLDD    = SIGLDD   *FAC*PARMDL(42)
9585       SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
9586       SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
9587       SIGHDD    = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
9588      &            *FAC*PARMDL(42)
9589
9590 C  double pomeron scattering
9591
9592       SIGCDF(0) = 0.D0
9593       DO 170 I=1,4
9594         SIGCDF(I) = SIGCDF(I)*FAC
9595         SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
9596  170  CONTINUE
9597
9598       SIG1SO    = SIG1SO   *FAC
9599       SIG1HA    = SIG1HA   *FAC
9600
9601       SIGINE    = SIGTOT - SIGELA
9602
9603 C  user-forced change of diffractive cross section
9604
9605       IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
9606
9607 C  use optional explicit parametrization for single-diffraction
9608
9609         SIGSD1 = SIGLSD(1)+SIGHSD(1)
9610         SIGSD2 = SIGLSD(2)+SIGHSD(2)
9611         SS = EE*EE
9612         XI_MIN = 1.5D0/SS
9613         XI_MAX = PARMDL(45)**2
9614         CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
9615      &    SIG_SD1,SIG_SD2,SIG_DD)
9616         SIG_SD1 = SIG_SD1*PARMDL(40)
9617         SIG_SD2 = SIG_SD2*PARMDL(41)
9618
9619 **sr
9620 C       DEL_SD1 = SIG_SD1-SIGSD1
9621         DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
9622 **
9623
9624         FAC = SIGLSD(1)/SIGSD1
9625         SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
9626         SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
9627
9628 C       DEL_SD2 = SIG_SD2-SIGSD2
9629         DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
9630
9631         FAC = SIGLSD(2)/SIGSD2
9632         SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
9633         SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
9634
9635         IF(ISWMDL(30).GE.2) THEN
9636
9637 C  use explicit parametrization also for double diffraction diss.
9638           SIGDD  = SIGLDD+SIGHDD
9639           SIG_DD = SIG_DD*PARMDL(42)
9640           DEL_DD = SIG_DD-SIGDD
9641           FAC = SIGLDD/SIGDD
9642           SIGLDD = SIGLDD+FAC*DEL_DD
9643           SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
9644           SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
9645
9646         ELSE
9647
9648 C  rescale double diffraction cross sections
9649           SIGLDD    = SIGLDD   *PARMDL(42)
9650           SIGHDD    = SIGHDD   *PARMDL(42)
9651           SIGCOR = DEL_SD1 + DEL_SD2
9652      &      +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9653
9654         ENDIF
9655
9656       ELSE
9657
9658 C  rescale unitarized cross sections for diffraction dissociation
9659
9660         SIGLSD(1) = SIGLSD(1)*PARMDL(40)
9661         SIGHSD(1) = SIGHSD(1)*PARMDL(40)
9662         SIGLSD(2) = SIGLSD(2)*PARMDL(41)
9663         SIGHSD(2) = SIGHSD(2)*PARMDL(41)
9664         SIGLDD    = SIGLDD   *PARMDL(42)
9665         SIGHDD    = SIGHDD   *PARMDL(42)
9666         SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
9667      &          +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
9668      &          +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9669
9670       ENDIF
9671
9672 C  non-diffractive inelastic cross section
9673
9674       SIGNDF    = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9675      &            -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9676      &            -SIGLDD-SIGHDD
9677
9678 C  specify elastic scattering channel
9679
9680  500  CONTINUE
9681       IF(IFPAP(1).NE.22) THEN
9682         VMESA(1) = PHO_PNAME(IFPAB(1),0)
9683       ELSE
9684         VMESA(1) = 'rho           '
9685       ENDIF
9686       IF(IFPAP(2).NE.22) THEN
9687         VMESB(1) = PHO_PNAME(IFPAB(2),0)
9688       ELSE
9689         VMESB(1) = 'rho           '
9690       ENDIF
9691
9692 C  write out physical cross sections
9693
9694       IF(IDEB(57).GE.5) THEN
9695         WRITE(LO,'(/1X,A,I3,/1X,A)')
9696      &    'PHO_XSECT: cross sections (mb) for combination',IP,
9697      &    '----------------------------------------------'
9698         WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
9699         WRITE(LO,'(5X,A,E12.3)') '             total ',SIGTOT
9700         WRITE(LO,'(5X,A,E12.3)') '    purely elastic ',SIGELA
9701         WRITE(LO,'(5X,A,E12.3)') '         inelastic ',SIGINE
9702         WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
9703      &    SIGLSD(1)+SIGHSD(1)
9704         IF(IDEB(57).GE.7) THEN
9705           WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLSD(1)
9706           WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHSD(1)
9707         ENDIF
9708         WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
9709      &    SIGLSD(2)+SIGHSD(2)
9710         IF(IDEB(57).GE.7) THEN
9711           WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLSD(2)
9712           WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHSD(2)
9713         ENDIF
9714         WRITE(LO,'(5X,A,E12.3)') '       double diff ',SIGLDD+SIGHDD
9715         IF(IDEB(57).GE.7) THEN
9716           WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLDD
9717           WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHDD
9718         ENDIF
9719         WRITE(LO,'(5X,A,E12.3)') '    double pomeron ',SIGCDF(0)
9720         IF(IDEB(57).GE.7) THEN
9721           WRITE(LO,'(5X,A,E12.3)') '    purely elastic ',SIGCDF(1)
9722           WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
9723           WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
9724           WRITE(LO,'(5X,A,E12.3)') '   excitation both ',SIGCDF(4)
9725         ENDIF
9726         WRITE(LO,'(5X,A,E12.3)') '     elastic slope ',SLOEL
9727         DO 200 I=1,4
9728           DO 210 J=1,4
9729             IF(SIGVM(I,J).GT.DEPS) THEN
9730               WRITE(LO,'(1X,3A)') 'q-elastic production of ',
9731      &          VMESA(I),VMESB(J)
9732               WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
9733               IF((I.NE.0).AND.(J.NE.0))
9734      &          WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
9735             ENDIF
9736  210      CONTINUE
9737  200    CONTINUE
9738         IF(IDEB(57).GE.7) THEN
9739           WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
9740           WRITE(LO,'(5X,A,E12.3)') '  one-pomeron soft ',SIG1SO
9741           WRITE(LO,'(5X,A,E12.3)') '  one-pomeron hard ',SIG1HA
9742           WRITE(LO,'(5X,A,E12.3)') '  pomeron exchange ',SIGPOM
9743           WRITE(LO,'(5X,A,E12.3)') '  reggeon exchange ',SIGREG
9744           WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
9745           WRITE(LO,'(5X,A,E12.3/)')'   hard direct QCD ',
9746      &      DREAL(DSIGH(15))
9747         ENDIF
9748       ENDIF
9749
9750       ECM = ETMP
9751
9752       END
9753
9754 *$ CREATE PHO_IMPAMP.FOR
9755 *COPY PHO_IMPAMP
9756 CDECK  ID>, PHO_IMPAMP
9757       SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
9758 C*********************************************************************
9759 C
9760 C     calculation of physical  impact parameter amplitude
9761 C
9762 C     input:   EE      cm energy (GeV)
9763 C              BMIN    lower bound in B
9764 C              BMAX    upper bound in B
9765 C              NSTEP   number of values (linear)
9766 C
9767 C     output:  values written to output unit
9768 C
9769 C*********************************************************************
9770       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9771       SAVE
9772
9773       PARAMETER(ONEM=-1.D0,
9774      &         THOUS=1.D3,
9775      &          DEPS=1.D-20)
9776
9777 C  input/output channels
9778       INTEGER LI,LO
9779       COMMON /POINOU/ LI,LO
9780 C  event debugging information
9781       INTEGER NMAXD
9782       PARAMETER (NMAXD=100)
9783       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9784      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9785       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9786      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9787 C  model switches and parameters
9788       CHARACTER*8 MDLNA
9789       INTEGER ISWMDL,IPAMDL
9790       DOUBLE PRECISION PARMDL
9791       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9792 C  global event kinematics and particle IDs
9793       INTEGER IFPAP,IFPAB
9794       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9795       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9796 C  complex Born graph amplitudes used for unitarization
9797       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9798      &                AMHMDD,AMPDP
9799       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9800      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9801
9802       ECM=EE
9803       BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
9804 C
9805       WRITE(LO,'(3(/,1X,A))')
9806      &  'impact parameter amplitudes:',
9807      &  '  B  AMP-EL  AMP-LMSD(1,2)  AMP-HMSD(1,2)  AMP-LMDD  AMP-HMDD',
9808      &  '-------------------------------------------------------------'
9809 C
9810       BB = BMIN
9811       DO 100 I=1,NSTEP
9812 C  calculate impact parameter amplitudes
9813         IF(I.EQ.1) THEN
9814           CALL PHO_EIKON(1,-1,BMIN)
9815         ELSE
9816           CALL PHO_EIKON(1,1,BB)
9817         ENDIF
9818         WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
9819      &    DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
9820      &    DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
9821         BB = BB+BSTEP
9822  100  CONTINUE
9823
9824       END
9825
9826 *$ CREATE PHO_PRBDIS.FOR
9827 *COPY PHO_PRBDIS
9828 CDECK  ID>, PHO_PRBDIS
9829       SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
9830 C*********************************************************************
9831 C
9832 C     calculation of multi interactions probabilities
9833 C
9834 C     input:  IP        particle combination to scatter
9835 C             ECM       CMS energy
9836 C             IE        index for weight storing
9837 C             /PROBAB/
9838 C             IMAX      max. number of soft pomeron interactions
9839 C             KMAX      max. number of hard pomeron interactions
9840 C
9841 C     output: /PROBAB/
9842 C             PROB      field of probabilities
9843 C
9844 C*********************************************************************
9845       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9846       SAVE
9847
9848       PARAMETER ( EPS=1.D-10 )
9849
9850 C  input/output channels
9851       INTEGER LI,LO
9852       COMMON /POINOU/ LI,LO
9853 C  event debugging information
9854       INTEGER NMAXD
9855       PARAMETER (NMAXD=100)
9856       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9857      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9858       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9859      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9860 C  Reggeon phenomenology parameters
9861       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
9862      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
9863       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
9864      &                ALREG,ALREGP,GR(2),B0REG(2),
9865      &                GPPP,GPPR,B0PPP,B0PPR,
9866      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
9867 C  parameters of 2x2 channel model
9868       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
9869       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
9870 C  Born graph cross sections and slopes
9871       INTEGER Max_pro_3
9872       PARAMETER ( Max_pro_3 = 16 )
9873       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9874      &                SIGD1,SIGD2,DSIGH
9875       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9876      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9877 C  obsolete cut-off information
9878       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
9879       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
9880 C  Born graph cross sections after applying diffraction model
9881       DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
9882      &                 SBOLPO,SBODPO
9883       COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
9884      &                SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
9885      &                SBODPO(0:4,4)
9886 C  cross sections
9887       INTEGER IPFIL,IFAFIL,IFBFIL
9888       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9889      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9890      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9891      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9892      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9893       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9894      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9895      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9896      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9897      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9898      &                IPFIL,IFAFIL,IFBFIL
9899 C  cut probability distribution
9900       INTEGER IEETA1,IIMAX,KKMAX
9901       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
9902       INTEGER IEEMAX,IMAX,KMAX
9903       REAL PROB
9904       DOUBLE PRECISION EPTAB
9905       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
9906      &                IEEMAX,IMAX,KMAX
9907 C  energy-interpolation table
9908       INTEGER IEETA2
9909       PARAMETER ( IEETA2 = 20 )
9910       INTEGER ISIMAX
9911       DOUBLE PRECISION SIGTAB,SIGECM
9912       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
9913 C  average number of cut soft and hard ladders (obsolete)
9914       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
9915       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
9916 C  some constants
9917       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9918       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9919      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9920 C  integration precision for hard cross sections (obsolete)
9921       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9922       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9923 C  model switches and parameters
9924       CHARACTER*8 MDLNA
9925       INTEGER ISWMDL,IPAMDL
9926       DOUBLE PRECISION PARMDL
9927       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9928 C  unitarized amplitudes for different diffraction channels
9929       DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
9930      &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
9931      &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
9932      &                 ZXL,BXL
9933       COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
9934      &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
9935      &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
9936      &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
9937      &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
9938      &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
9939      &                ZXL(4,4),BXL(4,4)
9940
9941 C  local variables
9942       DIMENSION  AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
9943       PARAMETER (ICHMAX=40)
9944       DIMENSION CHIFAC(4,4),AMPCOF(4)
9945       DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
9946       DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
9947
9948 C  combinatorical factors
9949       DATA      CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
9950      &                   1.D0,-1.D0, 1.D0,-1.D0,
9951      &                   1.D0,-1.D0,-1.D0, 1.D0,
9952      &                   1.D0, 1.D0, 1.D0, 1.D0 /
9953
9954       DATA FACLOG /           .000000000000000D+00,
9955      &  .000000000000000D+00, .693147180559945D+00,
9956      &  .109861228866811D+01, .138629436111989D+01,
9957      &  .160943791243410D+01, .179175946922805D+01,
9958      &  .194591014905531D+01, .207944154167984D+01,
9959      &  .219722457733622D+01, .230258509299405D+01,
9960      &  .239789527279837D+01, .248490664978800D+01,
9961      &  .256494935746154D+01, .263905732961526D+01,
9962      &  .270805020110221D+01, .277258872223978D+01,
9963      &  .283321334405622D+01, .289037175789616D+01,
9964      &  .294443897916644D+01, .299573227355399D+01,
9965      &  .304452243772342D+01, .309104245335832D+01,
9966      &  .313549421592915D+01, .317805383034795D+01,
9967      &  .321887582486820D+01, .325809653802148D+01,
9968      &  .329583686600433D+01, .333220451017520D+01,
9969      &  .336729582998647D+01, .340119738166216D+01 /
9970
9971       DATA  ELAST / 0.D0 /
9972       DATA  IPLAST / 0 /
9973
9974 C  test for redundant calculation: skip cs calculation
9975       IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
9976         ELAST = ECM
9977         IPLAST = IP
9978         CALL PHO_XSECT(IP,0,ELAST)
9979         ISIMAX = IE
9980         SIGECM(IP,IE) = ECM
9981         SIGTAB(IP,1,IE) = SIGTOT
9982         SIGTAB(IP,2,IE) = SIGELA
9983         J = 2
9984         DO 5 I=0,4
9985           DO 6 K=0,4
9986             J = J+1
9987             SIGTAB(IP,J,IE) = SIGVM(I,K)
9988  6        CONTINUE
9989  5      CONTINUE
9990         SIGTAB(IP,28,IE) = SIGINE
9991         SIGTAB(IP,29,IE) = SIGDIR
9992         SIGTAB(IP,30,IE) = SIGLSD(1)
9993         SIGTAB(IP,31,IE) = SIGLSD(2)
9994         SIGTAB(IP,32,IE) = SIGHSD(1)
9995         SIGTAB(IP,33,IE) = SIGHSD(2)
9996         SIGTAB(IP,34,IE) = SIGLDD
9997         SIGTAB(IP,35,IE) = SIGHDD
9998         SIGTAB(IP,36,IE) = SIGCDF(0)
9999         SIGTAB(IP,37,IE) = SIG1SO
10000         SIGTAB(IP,38,IE) = SIG1HA
10001         SIGTAB(IP,39,IE) = SLOEL
10002         J = 39
10003         DO 7 I=1,4
10004           DO 8 K=1,4
10005             J = J+1
10006             SIGTAB(IP,J,IE) = SLOVM(I,K)
10007  8        CONTINUE
10008  7      CONTINUE
10009         SIGTAB(IP,56,IE) = SIGPOM
10010         SIGTAB(IP,57,IE) = SIGREG
10011         SIGTAB(IP,58,IE) = SIGHAR
10012         SIGTAB(IP,59,IE) = SIGDIR
10013         SIGTAB(IP,60,IE) = SIGTR1(1)
10014         SIGTAB(IP,61,IE) = SIGTR1(2)
10015         SIGTAB(IP,62,IE) = SIGTR2(1)
10016         SIGTAB(IP,63,IE) = SIGTR2(2)
10017         SIGTAB(IP,64,IE) = SIGLOO
10018         SIGTAB(IP,65,IE) = SIGDPO(1)
10019         SIGTAB(IP,66,IE) = SIGDPO(2)
10020         SIGTAB(IP,67,IE) = SIGDPO(3)
10021         SIGTAB(IP,68,IE) = SIGDPO(4)
10022
10023 C  consistency check
10024         SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10025      &          -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
10026      &          -SIGLDD-SIGHDD
10027
10028         IF(SIGNDF.LE.0.D0) THEN
10029           WRITE(LO,'(//1X,A,/)')
10030      &      'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
10031           WRITE(LO,'(1X,A,I3,1P,2E12.4)')
10032      &      'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
10033           WRITE(LO,'(4X,A,/1P,8E10.3)')
10034      &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
10035      &      SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
10036      &      SIGLSD(2),SIGLDD
10037           STOP
10038         ENDIF
10039
10040         IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
10041           write(LO,*) '------------------------------------------------'
10042           write(LO,*) 'IP,ECM:',IP,ECM
10043           write(LO,*) 'SIGTOT:',SIGTOT
10044           write(LO,*) 'SIGELA:',SIGELA
10045           write(LO,*) 'SIGVM :',SIGVM(0,0)
10046           write(LO,*) 'SIGCDF:',SIGCDF(0)
10047           write(LO,*) 'SIGDIR:',SIGDIR
10048           write(LO,*) 'SIGLSD:',SIGLSD
10049           write(LO,*) 'SIGHSD:',SIGHSD
10050           write(LO,*) 'SIGLDD:',SIGLDD
10051           write(LO,*) 'SIGHDD:',SIGHDD
10052           write(LO,*) 'SIGNDF:',SIGNDF
10053
10054           write(LO,*) 'SIGPOM:',SIGPOM
10055           write(LO,*) 'SIGREG:',SIGREG
10056           write(LO,*) 'SIGHAR:',SIGHAR
10057           write(LO,*) 'SIGDIR:',SIGDIR
10058           write(LO,*) 'SIGTR1:',SIGTR1
10059           write(LO,*) 'SIGTR2:',SIGTR2
10060           write(LO,*) 'SIGLOO:',SIGLOO
10061           write(LO,*) 'SIGDPO:',SIGDPO
10062           write(LO,*) 'SIG1SO:',SIG1SO
10063           write(LO,*) 'SIG1HA:',SIG1HA
10064         ENDIF
10065
10066         SIGTAB(IP,77,IE) = PTCUT(IP)
10067         SIGTAB(IP,78,IE) = SIGNDF
10068
10069         AUXFAC = PI2/SIGNDF
10070         IF(ISWMDL(1).EQ.3) THEN
10071           DO 133 I=1,4
10072             AMPCOF(I) = 0.D0
10073             DO 135 K=1,4
10074               AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
10075  135        CONTINUE
10076             AMPCOF(I) = AMPCOF(I)*AUXFAC
10077  133      CONTINUE
10078         ENDIF
10079 C
10080 *       BMAX=5.D0*SQRT(DBLE(BPOM))
10081         BMAX=10.D0
10082         EPTAB(IP,IE) = ECM
10083         CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
10084 C
10085       ENDIF
10086 C
10087       DO 160 K=0,KMAX
10088         DO 170 I=0,IMAX
10089           PROB(IP,IE,I,K) = 0.D0
10090  170    CONTINUE
10091  160  CONTINUE
10092       DO 120 I=1,ICHMAX
10093         PCHAIN(1,I) = 0.D0
10094         PCHAIN(2,I) = 0.D0
10095  120  CONTINUE
10096 C
10097 C  main cross section loop
10098 C**********************************************************
10099       DO 5000 IB=1,NGAUSO
10100         B24=XPNT(IB)**2/4.D0
10101         FAC = XPNT(IB)*WGHT(IB)
10102 C
10103         IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
10104 C
10105 C  amplitude construction
10106           DO 525 I=1,4
10107             AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
10108      &              +ZXR(1,I)*EXP(-B24/BXR(1,I))
10109             AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
10110             AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
10111      &              -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
10112      &              -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
10113      &              -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
10114      &              -ZXL(1,I)*EXP(-B24/BXL(1,I))
10115             AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
10116      &              +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
10117      &              +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
10118      &              +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
10119             AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
10120             AB(2,I) = AB(2,I)
10121             AB(3,I) = 0.D0
10122             AB(4,I) = 0.D0
10123 *
10124  525      CONTINUE
10125 C
10126           DO 460 I=1,4
10127             DO 500 K=1,4
10128               ABSUM2(I,K) = 0.D0
10129               DO 550 L=1,4
10130                 ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
10131  550          CONTINUE
10132               ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
10133  500        CONTINUE
10134  460      CONTINUE
10135           DO 600 I=1,4
10136             CHI2(I) = 0.D0
10137             DO 650 K=1,4
10138               CHI2(I) = CHI2(I) + ABSUM2(K,I)
10139  650        CONTINUE
10140  600      CONTINUE
10141 C  sums instead of products
10142           DO 660 I=1,4
10143             DO 670 KD=1,4
10144               DTMP = ABS(ABSUM2(I,KD))
10145               IF(DTMP.LT.1.D-30) THEN
10146                 ABSUM2(I,KD) = -50.D0
10147               ELSE
10148                 ABSUM2(I,KD) = LOG(DTMP)
10149               ENDIF
10150  670        CONTINUE
10151  660      CONTINUE
10152
10153           IF(MAX(IMAX,KMAX).GT.30) THEN
10154             WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
10155      &        'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
10156             CALL PHO_ABORT
10157           ENDIF
10158
10159           DO 700 KD=1,4
10160             DO 750 I=1,4
10161               ABSTMP(I) = ABSUM2(I,KD)
10162  750        CONTINUE
10163 C  recursive sum
10164             CHITMP(1) = -ABSUM2(1,KD)
10165             DO 800 I=0,IMAX
10166               CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
10167               CHITMP(2) = -ABSTMP(2)
10168               DO 810 K=0,KMAX
10169                 CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
10170 C  calculation of elastic part
10171                 DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
10172                 IF(DTMP.LT.-30.D0) THEN
10173                   DTMP = 0.D0
10174                 ELSE
10175                   DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
10176                 ENDIF
10177                 PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
10178  810          CONTINUE
10179  800        CONTINUE
10180  700      CONTINUE
10181           PROB(IP,IE,0,0) = 0.D0
10182 C
10183 C**********************************************************
10184         ELSE
10185           WRITE(LO,'(1X,A,I3)')
10186      &      'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
10187           STOP
10188         ENDIF
10189  5000 CONTINUE
10190
10191 C  debug output
10192       IF(IDEB(55).GE.15) THEN
10193         WRITE(LO,'(/,1X,A,I3,E11.4)')
10194      &    'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
10195      &    IP,ECM
10196         DO 905 I=0,MIN(IMAX,5)
10197           DO 915 K=0,MIN(KMAX,5)
10198             IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
10199      &        WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
10200  915      CONTINUE
10201  905    CONTINUE
10202       ENDIF
10203 C  string probability (uncorrected)
10204       IF(IDEB(55).GE.5) THEN
10205         DO 955 I=0,IMAX
10206           DO 965 K=0,KMAX
10207             INDX = 2*I+2*K
10208             IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
10209               PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
10210             ENDIF
10211  965      CONTINUE
10212  955    CONTINUE
10213         WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
10214      &    'list of selected probabilities (uncorr,ECM)',ECM
10215         WRITE(LO,'(10X,A)') 'I,   0HPOM,   1HPOM,   2HPOM'
10216         DO 183 I=0,IIMAX
10217           IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
10218      &      WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
10219      &      PROB(IP,IE,I,1),PROB(IP,IE,I,2)
10220  183    CONTINUE
10221       ENDIF
10222 C  substract high-mass single and double diffraction
10223       PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
10224      &                 -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
10225       PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
10226 C
10227 C  probability check
10228       CHKSUM = 0.D0
10229       PRONEG = 0.D0
10230       AVERI =  0.D0
10231       AVERK =  0.D0
10232       AVERL =  0.D0
10233       AVERM =  0.D0
10234       AVERN =  0.D0
10235       SIGMI =  0.D0
10236       SIGMK =  0.D0
10237       SIGML =  0.D0
10238       SIGMM =  0.D0
10239       DO 1001 I=0,IMAX
10240         PSOFT(I) = 0.D0
10241  1001 CONTINUE
10242       DO 1002 K=0,KMAX
10243         PHARD(K) = 0.D0
10244  1002 CONTINUE
10245       DO 1000 K=0,KMAX
10246         DO 1010 I=0,IMAX
10247           TMP = PROB(IP,IE,I,K)
10248           IF(TMP.LT.0.D0) THEN
10249             IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
10250               WRITE(LO,'(1X,A,4I4,E14.4)')
10251      &          'PHO_PRBDIS: neg.probability:',
10252      &              IP,IE,I,K,PROB(IP,IE,I,K)
10253             ENDIF
10254             PRONEG = PRONEG+TMP
10255             TMP = 0.D0
10256           ENDIF
10257           CHKSUM = CHKSUM+TMP
10258           AVERI = AVERI+DBLE(I)*TMP
10259           AVERK = AVERK+DBLE(K)*TMP
10260           SIGMI = SIGMI+DBLE(I**2)*TMP
10261           SIGMK = SIGMK+DBLE(K**2)*TMP
10262           PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
10263           PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
10264           PROB(IP,IE,I,K) = CHKSUM
10265  1010   CONTINUE
10266  1000 CONTINUE
10267 C
10268       IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
10269      &  'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
10270 C  cut probabilites output
10271       IF(IDEB(55).GE.5) THEN
10272         WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
10273         DO 185 I=1,ICHMAX
10274           IF(ABS(PCHAIN(1,I)).GT.1.D-10)
10275      &      WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
10276  185    CONTINUE
10277       ENDIF
10278 C  rescaling necessary
10279       IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
10280         FAC = 1.D0/CHKSUM
10281         IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
10282      &    'PHO_PRBDIS: rescaling of probabilities with factor',FAC
10283         DO 40 K=0,KMAX
10284           DO 50 I=0,IMAX
10285             PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
10286   50      CONTINUE
10287   40    CONTINUE
10288         AVERI = AVERI*FAC
10289         AVERK = AVERK*FAC
10290         AVERL = AVERL*FAC
10291         AVERM = AVERM*FAC
10292         SIGMI = SIGMI*FAC**2
10293         SIGMK = SIGMK*FAC**2
10294         SIGML = SIGML*FAC**2
10295         SIGMM = SIGMM*FAC**2
10296       ENDIF
10297 C
10298 C  probability to find Reggeon/Pomeron
10299       PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
10300       AVERJ = -PROB(IP,IE,0,0)*AVERI
10301       AVERII = AVERI-AVERJ
10302 C
10303       SIGTAB(IP,74,IE) = AVERII
10304       SIGTAB(IP,75,IE) = AVERK
10305       SIGTAB(IP,76,IE) = AVERJ
10306 C
10307       SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
10308       SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
10309 C
10310       IF(IDEB(55).GE.1) THEN
10311
10312 C  average interaction probabilities
10313         WRITE(LO,'(/1X,A,/1X,A)')
10314      &    'PHO_PRBDIS: expected interaction statistics',
10315      &    '-------------------------------------------'
10316         WRITE(LO,'(1X,A,E12.4,2I3)')
10317      &    'energy,IP,table index:',EPTAB(IP,IE),IP,IE
10318         WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
10319      &    IMAX,KMAX
10320         WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
10321      &    'averaged number of cuts per event (eff. cs):',SIGNDF,
10322      &    ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
10323      &    AVERII,AVERK,AVERJ,AVERL,AVERM,
10324      &    AVERI+AVERK+AVERL+AVERM
10325         WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
10326      &    'standard deviation ( sqrt(sigma) ):',
10327      &    ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
10328      &    SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
10329      &    SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
10330         WRITE(LO,'(1X,A)') 'cross section / probability  soft, hard'
10331         DO I=0,MIN(IMAX,KMAX)
10332           WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
10333      &      I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
10334         ENDDO
10335
10336 C  cross check of probability distribution and inclusive cross section
10337         PSsum_1 = 0.D0
10338         PSsum_2 = 0.D0
10339         PHsum_1 = 0.D0
10340         PHsum_2 = 0.D0
10341         do i=1,IMAX
10342           PSsum_1 = PSsum_1+PSOFT(i)*FAC
10343           PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
10344         enddo
10345         do k=1,KMAX
10346           PHsum_1 = PHsum_1+PHARD(k)
10347           PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
10348         enddo
10349         WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
10350      &    PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
10351
10352       ENDIF
10353
10354       END
10355
10356 *$ CREATE PHO_SAMPRO.FOR
10357 *COPY PHO_SAMPRO
10358 CDECK  ID>, PHO_SAMPRO
10359       SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
10360 C***********************************************************************
10361 C
10362 C     routine to sample kind of process
10363 C
10364 C     input:   IP        particle combination
10365 C              IFP1/2    PDG number of particle 1/2
10366 C              ECM       c.m. energy (GeV)
10367 C              PVIR1/2   virtuality of particle 1/2 (GeV**2, positive)
10368 C              SPROB     suppression factor for processes 1-7
10369 C                        due to rapidity gap survival probability
10370 C              IPROC     mode
10371 C                          -2     output of statistics
10372 C                          -1     initialization
10373 C                           0     sampling of process
10374 C
10375 C     output:  IPROC     kind of interaction process:
10376 C                           1  non-diffractive resolved process
10377 C                           2  elastic scattering
10378 C                           3  quasi-elastic rho/omega/phi production
10379 C                           4  central diffraction
10380 C                           5  single diffraction according to IDIFF1
10381 C                           6  single diffraction according to IDIFF2
10382 C                           7  double diffraction
10383 C                           8  single-resolved / direct processes
10384 C
10385 C***********************************************************************
10386
10387       IMPLICIT NONE
10388
10389       SAVE
10390
10391       INTEGER IP,IFP1,IFP2,IPROC
10392       DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
10393
10394 C  input/output channels
10395       INTEGER LI,LO
10396       COMMON /POINOU/ LI,LO
10397 C  event debugging information
10398       INTEGER NMAXD
10399       PARAMETER (NMAXD=100)
10400       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10401      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10402       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10403      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10404 C  cross sections
10405       INTEGER IPFIL,IFAFIL,IFBFIL
10406       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10407      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10408      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10409      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10410      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10411       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10412      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10413      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10414      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10415      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10416      &                IPFIL,IFAFIL,IFBFIL
10417 C  model switches and parameters
10418       CHARACTER*8 MDLNA
10419       INTEGER ISWMDL,IPAMDL
10420       DOUBLE PRECISION PARMDL
10421       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10422 C  general process information
10423       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10424       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10425 C  event weights and generated cross section
10426       INTEGER IPOWGC,ISWCUT,IVWGHT
10427       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
10428       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
10429      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
10430
10431       DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
10432       DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
10433       DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
10434
10435       INTEGER I,K,KMAX
10436       DOUBLE PRECISION DT_RNDM
10437       DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
10438
10439       IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
10440      &  'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
10441      &  IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10442
10443       IF(IPROC.GE.0) THEN
10444
10445 C  interpolate cross sections
10446         CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
10447
10448 C  cross check
10449         IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
10450           WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
10451      &      'PHO_SAMPRO: inconsistent gap survival probability',
10452      &      'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
10453      &      KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10454         ENDIF
10455
10456 C  calculate cumulative probabilities
10457         IF(ISWMDL(1).EQ.3) THEN
10458           IF(ISWMDL(2).GE.1) THEN
10459             SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
10460             SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
10461             SIGDDI    = SIGLDD+SIGHDD
10462             SIGNDR    = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10463      &                - SIGSDI(1)-SIGSDI(2)-SIGDDI
10464             XPROB(1)  = SIGNDR*SPROB*DBLE(IPRON(1,IP))
10465             XPROB(2)  = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
10466             XPROB(3)  = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
10467             XPROB(4)  = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
10468             XPROB(5)  = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
10469             XPROB(6)  = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
10470             XPROB(7)  = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
10471             XPROB(8)  = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
10472           ELSE
10473             SIGHR = 0.D0
10474             IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
10475             SIGHD = 0.D0
10476             IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
10477             XPROB(1) = SIGHR/(SIGHR+SIGHD)
10478             XPROB(2) = XPROB(1)
10479             XPROB(3) = XPROB(1)
10480             XPROB(4) = XPROB(1)
10481             XPROB(5) = XPROB(1)
10482             XPROB(6) = XPROB(1)
10483             XPROB(7) = XPROB(1)
10484             XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
10485           ENDIF
10486
10487           IF(IDEB(11).GE.15) THEN
10488             WRITE(LO,'(1X,A,I3)')
10489      &        'PHO_SAMPRO: partial cross sections for IP',IP
10490             WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
10491             DO 240 I=2,8
10492               WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
10493  240        CONTINUE
10494           ENDIF
10495
10496         ELSE
10497           WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
10498      &      ISWMDL(1)
10499           CALL PHO_ABORT
10500         ENDIF
10501
10502         IF(XPROB(8).LT.1.D-20) THEN
10503           IF(IDEB(11).GE.2)
10504      &      WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
10505      &      'activated processes have vanishing cross section sum',
10506      &      'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
10507           IPROC = 0
10508           RETURN
10509         ENDIF
10510
10511 C  sample process
10512         XI = DT_RNDM(XI)*XPROB(8)
10513         DO 100 I=1,8
10514           IF(XI.LE.XPROB(I)) GOTO 110
10515  100    CONTINUE
10516  110    CONTINUE
10517         IPROC = MIN(I,8)
10518
10519         CALLS(IP)     = CALLS(IP)+1.D0
10520         PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
10521         ECMSUM(IP)    = ECMSUM(IP)+ECM
10522         IF(ISWMDL(2).GE.1) THEN
10523           SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
10524         ELSE
10525           SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
10526         ENDIF
10527
10528 C  debug output
10529         IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
10530      &    'PHO_SAMPRO: IP,CALL,PROC-ID',
10531      &    IP,INT(CALLS(IP)+0.1D0),IPROC
10532
10533 C  statistics initialization
10534       ELSE IF(IPROC.EQ.-1) THEN
10535         DO 260 K=1,4
10536           DO 250 I=1,8
10537             PRO(I,K) = 0.D0
10538  250      CONTINUE
10539           CALLS(K)  = 0.D0
10540           SIGSUM(K) = 0.D0
10541           ECMSUM(K) = 0.D0
10542  260    CONTINUE
10543
10544 C  write out statistics
10545       ELSE IF(IPROC.EQ.-2) THEN
10546         KMAX = 4
10547         IF(ISWMDL(2).EQ.0) KMAX=1
10548         DO 270 K=1,KMAX
10549           IF(CALLS(K).GT.0.5D0) THEN
10550             SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
10551             ECMSUM(K) = ECMSUM(K)/CALLS(K)
10552             IF(IDEB(11).GE.0) THEN
10553               WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
10554      &          'PHO_SAMPRO: internal process statistics ',
10555      &          '(IP,<Ecm>)',K,ECMSUM(K),
10556      &          '---------------------------------------'
10557               WRITE(LO,'(8X,A)')
10558      &          '        process      sampled    cross section'
10559               IF(ISWMDL(2).GE.1) THEN
10560                 WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
10561      &            '    all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10562      &            ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
10563      &            '          elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
10564      &            'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
10565      &            '   double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
10566      &            ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
10567      &            ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
10568      &            ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
10569      &            ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
10570               ELSE
10571                 WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
10572      &            '    all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10573      &            '  double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
10574      &            ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
10575               ENDIF
10576             ENDIF
10577           ENDIF
10578  270    CONTINUE
10579       ENDIF
10580
10581       END
10582
10583 *$ CREATE PHO_SAMPRB.FOR
10584 *COPY PHO_SAMPRB
10585 CDECK  ID>, PHO_SAMPRB
10586       SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
10587 C********************************************************************
10588 C
10589 C     routine to sample number of cut graphs of different kind
10590 C
10591 C     input:  IP      scattering particle combination
10592 C             ECMI    CMS energy
10593 C             IP      -1         initialization
10594 C                     -2         output of statistics
10595 C                     others     sampling of cuts
10596 C
10597 C     output: ISAM    number of soft Pomerons cut
10598 C             JSAM    number of soft Reggeons cut
10599 C             KSAM    number of hard Pomerons cut
10600 C
10601 C     PHO_PRBDIS has to be called before
10602 C
10603 C********************************************************************
10604       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10605       SAVE
10606
10607 C  input/output channels
10608       INTEGER LI,LO
10609       COMMON /POINOU/ LI,LO
10610 C  event debugging information
10611       INTEGER NMAXD
10612       PARAMETER (NMAXD=100)
10613       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10614      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10615       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10616      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10617 C  model switches and parameters
10618       CHARACTER*8 MDLNA
10619       INTEGER ISWMDL,IPAMDL
10620       DOUBLE PRECISION PARMDL
10621       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10622 C  general process information
10623       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10624       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10625 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
10626       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
10627       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
10628       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
10629      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
10630 C  obsolete cut-off information
10631       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10632       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10633 C  cut probability distribution
10634       INTEGER IEETA1,IIMAX,KKMAX
10635       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
10636       INTEGER IEEMAX,IMAX,KMAX
10637       REAL PROB
10638       DOUBLE PRECISION EPTAB
10639       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
10640      &                IEEMAX,IMAX,KMAX
10641 C  global event kinematics and particle IDs
10642       INTEGER IFPAP,IFPAB
10643       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
10644       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
10645 C  cross sections
10646       INTEGER IPFIL,IFAFIL,IFBFIL
10647       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10648      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10649      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10650      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10651      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10652       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10653      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10654      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10655      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10656      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10657      &                IPFIL,IFAFIL,IFBFIL
10658 C  table of particle indices for recursive PHOJET calls
10659       INTEGER MAXIPX
10660       PARAMETER ( MAXIPX = 100 )
10661       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
10662       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
10663      &                IPOIX1,IPOIX2,IPOIX3
10664
10665       DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
10666
10667 C  sample number of interactions
10668       IF(IP.GE.0) THEN
10669         ITER = 0
10670         ECMX = ECMI
10671         ECMC = ECMI
10672         KLIM = 1
10673         IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
10674           IF(IPAMDL(16).EQ.0) ECMC = SECM
10675           KLIM = 0
10676         ENDIF
10677
10678 C  sample up to kinematic limits only
10679         IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
10680         IF(IMAX1.LT.1) THEN
10681           IF(IPAMDL(2).EQ.1) THEN
10682 C  reggeon allowed
10683             ISAM = 0
10684             JSAM = 1
10685             KSAM = 0
10686             AVERB(3,IP) = AVERB(3,IP)+1.D0
10687           ELSE
10688 C  only pomeron even at very low energies
10689             ISAM = 1
10690             JSAM = 0
10691             KSAM = 0
10692             AVERB(1,IP) = AVERB(1,IP)+1.D0
10693           ENDIF
10694           AVERB(0,IP) = AVERB(0,IP)+1.D0
10695           GOTO 150
10696         ENDIF
10697 C  find interpolation factors
10698         IF(ECMX.LE.EPTAB(IP,1)) THEN
10699           I1 = 1
10700           I2 = 1
10701         ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
10702           DO 50 I=2,IEEMAX
10703             IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
10704  50       CONTINUE
10705  200      CONTINUE
10706           I1 = I-1
10707           I2 = I
10708         ELSE
10709           WRITE(LO,'(/1X,A,2E12.3)')
10710      &      'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
10711           CALL PHO_PREVNT(-1)
10712           I1 = IEEMAX
10713           I2 = IEEMAX
10714         ENDIF
10715         FAC2 = 0.D0
10716         IF(I1.NE.I2)
10717      &    FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
10718         FAC1=1.D0-FAC2
10719 C  reggeon probability
10720         PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
10721 C  calculate soft suppression factor
10722         IF(IP.EQ.1) FSUPP = PARMDL(35)**2
10723      &         /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
10724 C
10725  10     CONTINUE
10726         ITER = ITER+1
10727         XI = DT_RNDM(FAC2)
10728         DO 260 KSAM=0,KMAX
10729           DO 270 ISAM=0,IMAX
10730             PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
10731      &           +PROB(IP,I2,ISAM,KSAM)*FAC2
10732             IF(PRO.GT.XI) GOTO 100
10733  270      CONTINUE
10734  260    CONTINUE
10735         ISAM = MIN(IMAX,ISAM)
10736         KSAM = MIN(KMAX,KSAM)
10737
10738  100    CONTINUE
10739
10740         IF(ITER.GT.100) THEN
10741
10742           ISAM = 0
10743           JSAM = 1
10744           KSAM = 0
10745           IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
10746      &      'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
10747
10748         ELSE
10749
10750 C  reggeon contribution
10751           JSAM = 0
10752           IF(IPAMDL(2).EQ.1) THEN
10753             DO 90 I=1,ISAM
10754               IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
10755  90         CONTINUE
10756             ISAM = ISAM-JSAM
10757           ENDIF
10758 C  statistics of bare cuts
10759           IF(ITER.EQ.1) THEN
10760             AVERB(0,IP) = AVERB(0,IP)+1.D0
10761             AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
10762             AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
10763             AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
10764           ENDIF
10765 C  limitation given by field dimensions
10766           IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
10767
10768           IF(IP.EQ.1) THEN
10769
10770 C  reweight according to virtualities and PDF treatment
10771             IF(IPAMDL(115).GE.1) THEN
10772               IF(KSAM.EQ.0) THEN
10773                 IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
10774               ENDIF
10775             ENDIF
10776
10777 C  reduce number of cuts according to photon virtualities
10778             IF(IPAMDL(114).GE.1) THEN
10779  110          CONTINUE
10780               I = ISAM+JSAM
10781               WGX = FSUPP**I
10782               IF(DT_RNDM(WGX).GT.WGX) THEN
10783                 IF(ISAM+JSAM+KSAM.GT.1) THEN
10784                   IF(JSAM.GT.0) THEN
10785                     JSAM = JSAM-1
10786                     GOTO 110
10787                   ELSE IF(ISAM.GT.0) THEN
10788                     ISAM = ISAM-1
10789                     GOTO 110
10790                   ENDIF
10791                 ENDIF
10792               ENDIF
10793             ENDIF
10794
10795           ENDIF
10796
10797 C  phase space limitation
10798  120      CONTINUE
10799           XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
10800      &        +DBLE(2*KSAM)*PTCUT(IP)
10801           PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
10802           IF(DT_RNDM(XM).GT.PACC) THEN
10803             IF(ISAM+JSAM+KSAM.GT.1) THEN
10804               IF(JSAM.GT.0) THEN
10805                 JSAM = JSAM-1
10806                 GOTO 120
10807               ELSE IF(ISAM.GT.0) THEN
10808                 ISAM = ISAM-1
10809                 GOTO 120
10810               ELSE IF(KSAM.GT.KLIM) THEN
10811                 KSAM = KSAM-1
10812                 GOTO 120
10813               ENDIF
10814             ENDIF
10815           ENDIF
10816
10817         ENDIF
10818
10819         ISAM = ISAM+JSAM/2
10820         JSAM = MOD(JSAM,2)
10821 C  collect statistics
10822  150    CONTINUE
10823         ECMS1(IP) = ECMS1(IP)+ECMX
10824         ECMS2(IP) = ECMS2(IP)+ECMC
10825
10826         AVERC(0,IP) = AVERC(0,IP)+1.D0
10827         AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
10828         AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
10829         AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
10830 C
10831         IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
10832      &    'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
10833 C
10834 C  initialize statistics
10835       ELSE IF(IP.EQ.-1) THEN
10836         DO 60 I=1,4
10837           ECMS1(I) = 0.D0
10838           ECMS2(I) = 0.D0
10839           DO 65 K=0,3
10840             AVERB(K,I) = 0.D0
10841             AVERC(K,I) = 0.D0
10842  65       CONTINUE
10843
10844  60     CONTINUE
10845         RETURN
10846 C
10847 C  write out statistics
10848       ELSE IF(IP.EQ.-2) THEN
10849         WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
10850      &                        '----------------------------------'
10851         DO 70 I=1,4
10852           IF(AVERB(0,I).LT.2.D0) GOTO 75
10853           WRITE(LO,'(1X,A,I3,1P,2E13.3)')
10854      &      'statistics for IP,<Ecm_1>,<Ecm_2>',I,
10855      &      ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
10856           WRITE(LO,'(5X,A)')
10857      &      'average number of s-pom,h-pom,reg cuts (bare)'
10858           WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
10859      &      (AVERB(K,I)/AVERB(0,I),K=1,3)
10860           WRITE(LO,'(5X,A)')
10861      &      'average (with energy/virtuality corrections)'
10862           WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
10863      &      (AVERC(K,I)/AVERC(0,I),K=1,3)
10864
10865  75       CONTINUE
10866  70     CONTINUE
10867         RETURN
10868       ENDIF
10869       END
10870
10871 *$ CREATE PHO_TRIREG.FOR
10872 *COPY PHO_TRIREG
10873 CDECK  ID>, PHO_TRIREG
10874       SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
10875      &                     SIGTR,BTR)
10876 C**********************************************************************
10877 C
10878 C     calculation of triple-Pomeron total cross section
10879 C     according to Gribov's Regge theory
10880 C
10881 C     input:        S        squared cms energy
10882 C                   GA       coupling constant to diffractive line
10883 C                   AA       slope related to GA (GeV**-2)
10884 C                   GB       coupling constant to elastic line
10885 C                   BB       slope related to GB (GeV**-2)
10886 C                   DELTA    effective pomeron delta (intercept-1)
10887 C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
10888 C                   GPPP     triple-Pomeron coupling
10889 C                   BPPP     slope related to B0PPP (GeV**-2)
10890 C                   VIR2A    virtuality of particle a (GeV**2)
10891 C                   note: units of all coupling constants are mb**1/2
10892 C
10893 C     output:       SIGTR    total triple-Pomeron cross section
10894 C                   BTR      effective triple-Pomeron slope
10895 C                            (differs from diffractive slope!)
10896 C
10897 C     uses E_i (Exponential-Integral function)
10898 C
10899 C**********************************************************************
10900       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10901       SAVE
10902
10903       PARAMETER (EPS =0.0001D0)
10904
10905 C  input/output channels
10906       INTEGER LI,LO
10907       COMMON /POINOU/ LI,LO
10908 C  event debugging information
10909       INTEGER NMAXD
10910       PARAMETER (NMAXD=100)
10911       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10912      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10913       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10914      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10915 C  some constants
10916       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10917       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10918      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10919
10920 C  integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10921       SIGU = 2.5
10922 C  integration cut-off Sigma_L (min. squared mass of diff. blob)
10923       SIGL = 5.+VIR2A
10924 C  debug output
10925       IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10926      &       'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10927      &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10928 C
10929       IF(S.LT.5.D0) THEN
10930         SIGTR = 0.D0
10931         BTR = BPPP+BB
10932         RETURN
10933       ENDIF
10934 C  change units of ALPHAP to mb
10935       ALSCA  = ALPHAP*GEV2MB
10936 C
10937 C  cross section
10938       PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
10939      &        EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
10940       PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
10941       PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
10942 C
10943       SIGTR=PART1*(PART2-PART3)
10944 C
10945 C  slope
10946       PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
10947      &        (BB+BPPP+2.*ALPHAP*LOG(SIGU))
10948       PART2 = LOG(PART1)
10949       PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
10950       BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
10951       BTR = BTR-PART1
10952 C
10953       IF(SIGTR.LT.EPS) SIGTR = 0.D0
10954       IF(BTR.LT.BB)  BTR = BB
10955 C
10956       IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10957      &  'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
10958       END
10959
10960 *$ CREATE PHO_LOOREG.FOR
10961 *COPY PHO_LOOREG
10962 CDECK  ID>, PHO_LOOREG
10963       SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
10964      &                     VIR2A,VIR2B,SIGLO,BLO)
10965 C**********************************************************************
10966 C
10967 C     calculation of loop-Pomeron total cross section
10968 C     according to Gribov's Regge theory
10969 C
10970 C     input:        S        squared cms energy
10971 C                   GA       coupling constant to diffractive line
10972 C                   AA       slope related to GA (GeV**-2)
10973 C                   GB       coupling constant to elastic line
10974 C                   BB       slope related to GB (GeV**-2)
10975 C                   DELTA    effective pomeron delta (intercept-1)
10976 C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
10977 C                   GPPP     triple-Pomeron coupling
10978 C                   BPPP     slope related to B0PPP (GeV**-2)
10979 C                   VIR2A    virtuality of particle a (GeV**2)
10980 C                   VIR2B    virtuality of particle b (GeV**2)
10981 C                   note: units of all coupling constants are mb**1/2
10982 C
10983 C     output:       SIGLO    total loop-Pomeron cross section
10984 C                   BLO      effective loop-Pomeron slope
10985 C                            (differs from double diffractive slope!)
10986 C
10987 C     uses E_i (Exponential-Integral function)
10988 C
10989 C**********************************************************************
10990       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10991       SAVE
10992
10993       PARAMETER (EPS =0.0001D0)
10994
10995 C  input/output channels
10996       INTEGER LI,LO
10997       COMMON /POINOU/ LI,LO
10998 C  event debugging information
10999       INTEGER NMAXD
11000       PARAMETER (NMAXD=100)
11001       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11002      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11003       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11004      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11005 C  some constants
11006       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11007       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11008      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11009
11010 C  integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
11011       SIGU = 2.5
11012 C  integration cut-off Sigma_L (min. squared mass of diff. blob)
11013       SIGL = 5.+VIR2A+VIR2B
11014 C  debug output
11015       IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11016      &       'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
11017      &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11018 C
11019       IF(S.LT.5.D0) THEN
11020         SIGLO = 0.D0
11021         BLO = 2.D0*BPPP
11022         RETURN
11023       ENDIF
11024
11025 C
11026 C  change units of ALPHAP to mb
11027       ALSCA  = ALPHAP*GEV2MB
11028 C
11029 C  cross section
11030       PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
11031      &        EXP(-DELTA*BPPP/ALPHAP)
11032       PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
11033       PARTB=BPPP/ALPHAP+LOG(SIGU)
11034       SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
11035      &                    -PHO_EXPINT(PARTB*DELTA))
11036      &             +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
11037      &            )
11038 C
11039 C  slope
11040       PART1 = LOG(ABS(PARTA/PARTB))
11041      &       *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
11042       PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
11043       BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
11044       BLO = BLO-PART1
11045 C
11046       IF(SIGLO.LT.EPS) SIGLO = 0.D0
11047       IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
11048 C
11049       IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11050      &  'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
11051       END
11052
11053 *$ CREATE PHO_TRXPOM.FOR
11054 *COPY PHO_TRXPOM
11055 CDECK  ID>, PHO_TRXPOM
11056       SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
11057      &                     GPPP,BPPP,SIGDP,BDP)
11058 C**********************************************************************
11059 C
11060 C     calculation of total cross section of two tripe-Pomeron
11061 C     graphs in X configuration according to Gribov's Reggeon field
11062 C     theory
11063 C
11064 C     input:        S        squared cms energy
11065 C                   GA       coupling constant to elastic line 1
11066 C                   AA       slope related to GA (GeV**-2)
11067 C                   GB       coupling constant to elastic line 2
11068 C                   BB       slope related to GB (GeV**-2)
11069 C                   DELTA    effective pomeron delta (intercept-1)
11070 C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
11071 C                   BPPP     triple-Pomeron coupling
11072 C                   BTR      slope related to B0PPP (GeV**-2)
11073 C                   note: units of all coupling constants are mb**1/2
11074 C
11075 C     output:       SIGDP    total cross section for double-Pomeron
11076 C                            scattering
11077 C                   BDP      effective double-Pomeron slope
11078 C
11079 C**********************************************************************
11080       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11081       SAVE
11082
11083       PARAMETER (EPS =0.0001D0)
11084
11085 C  input/output channels
11086       INTEGER LI,LO
11087       COMMON /POINOU/ LI,LO
11088 C  event debugging information
11089       INTEGER NMAXD
11090       PARAMETER (NMAXD=100)
11091       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11092      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11093       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11094      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11095 C  model switches and parameters
11096       CHARACTER*8 MDLNA
11097       INTEGER ISWMDL,IPAMDL
11098       DOUBLE PRECISION PARMDL
11099       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11100 C  some constants
11101       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11102       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11103      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11104
11105       DIMENSION XWGH1(96),XPOS1(96)
11106
11107 C  lower integration cut-off Sigma_L
11108       SIGL = PARMDL(71)**2
11109 C  upper integration cut-off Sigma_U
11110       C = 1.D0-1.D0/PARMDL(70)**2
11111       C = MAX(PARMDL(72),C)
11112       SIGU = (1.D0-C)**2*S
11113 C  integration precision
11114       NGAUS1=16
11115 C
11116 C  debug output
11117       IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11118      &       'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
11119      &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11120 C
11121       IF(SIGU.LE.SIGL) THEN
11122         SIGDP = 0.D0
11123         BDP = AA+BB
11124         RETURN
11125       ENDIF
11126 C
11127 C  cross section
11128 C
11129       XIL = LOG(SIGL)
11130       XIU = LOG(SIGU)
11131       XI = LOG(S)
11132       FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
11133       ALPHA2 = 2.D0*ALPHAP
11134       ALOC = LOG(1.D0/(1.D0-C))
11135       CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
11136       XSUM = 0.D0
11137       DO 100 I1=1,NGAUS1
11138         AMXSQ  = EXP(XPOS1(I1))
11139         ALOSMX = LOG(S/AMXSQ)
11140         ALCSMX = LOG((1.D0-C)*S/AMXSQ)
11141         W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
11142         W = MAX(0.D0,W)
11143         WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
11144 C  supercritical part
11145         WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
11146         XSUM = XSUM + W*XWGH1(I1)/WN*WSC
11147  100  CONTINUE
11148       SIGDP = XSUM*FAC
11149 C
11150 C  slope
11151       BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
11152 C
11153       IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11154      &  'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
11155       END
11156
11157 *$ CREATE PHO_CHAN2A.FOR
11158 *COPY PHO_CHAN2A
11159 CDECK  ID>, PHO_CHAN2A
11160       SUBROUTINE PHO_CHAN2A(BB)
11161 C***********************************************************************
11162 C
11163 C     simple two channel model to realize low mass diffraction
11164 C     (version A, iteration of triple- and loop-Pomeron)
11165 C
11166 C     input:     BB      impact parameter (mb**1/2)
11167 C
11168 C     output:    /POINT4/
11169 C                AMPEL      elastic amplitude
11170 C                AMPVM(4,4) q-elastic VM production
11171 C                AMLMSD(2)  low mass single diffraction amplitude
11172 C                AMHMSD(2)  high mass single diffraction amplitude
11173 C                AMLMDD     low mass double diffraction amplitude
11174 C                AMHMDD     high mass double diffraction amplitude
11175 C                AMPDP(4)   central diffraction amplitude
11176 C
11177 C***********************************************************************
11178       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11179       SAVE
11180
11181       PARAMETER (DEPS  = 1.D-5,
11182      &           EIGHT = 8.D0)
11183
11184 C  input/output channels
11185       INTEGER LI,LO
11186       COMMON /POINOU/ LI,LO
11187 C  event debugging information
11188       INTEGER NMAXD
11189       PARAMETER (NMAXD=100)
11190       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11191      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11192       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11193      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11194 C  model switches and parameters
11195       CHARACTER*8 MDLNA
11196       INTEGER ISWMDL,IPAMDL
11197       DOUBLE PRECISION PARMDL
11198       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11199 C  some constants
11200       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11201       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11202      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11203 C  complex Born graph amplitudes used for unitarization
11204       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
11205      &                AMHMDD,AMPDP
11206       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
11207      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
11208 C  unitarized amplitudes for different diffraction channels
11209       DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
11210      &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
11211      &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
11212      &                 ZXL,BXL
11213       COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
11214      &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
11215      &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
11216      &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
11217      &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
11218      &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
11219      &                ZXL(4,4),BXL(4,4)
11220 C  Reggeon phenomenology parameters
11221       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
11222      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
11223       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
11224      &                ALREG,ALREGP,GR(2),B0REG(2),
11225      &                GPPP,GPPR,B0PPP,B0PPR,
11226      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
11227 C  parameters of 2x2 channel model
11228       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
11229       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
11230 C  global event kinematics and particle IDs
11231       INTEGER IFPAP,IFPAB
11232       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11233       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11234
11235 C  local variables
11236       DIMENSION  AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
11237      &           CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
11238      &           AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
11239       DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
11240
11241 C  combinatorical factors
11242       DATA      CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
11243      &                   1.D0,-1.D0, 1.D0,-1.D0,
11244      &                   1.D0,-1.D0,-1.D0, 1.D0,
11245      &                   1.D0, 1.D0, 1.D0, 1.D0 /
11246       DATA      EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
11247      &                   1.D0,-1.D0,-1.D0, 1.D0,
11248      &                  -1.D0, 1.D0,-1.D0, 1.D0,
11249      &                  -1.D0,-1.D0, 1.D0, 1.D0 /
11250       DATA      IELTAB / 1, 2, 3, 4,
11251      &                   2, 1, 4, 3,
11252      &                   3, 4, 1, 2,
11253      &                   4, 3, 2, 1 /
11254
11255       IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
11256      &  'PHO_CHAN2A: impact parameter B',BB
11257
11258       B24 = BB**2/4.D0
11259       DO 25 I=1,4
11260         AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
11261      &           +ZXR(1,I)*EXP(-B24/BXR(1,I))
11262         AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
11263         AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
11264         AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
11265         AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
11266      &           -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
11267      &           -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
11268         AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
11269         AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
11270         AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
11271         AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
11272  25   CONTINUE
11273
11274       DO 50 I=1,4
11275         ABSUM(I)  = 0.D0
11276         DO 75 II=9,1,-1
11277           ABSUM(I) = ABSUM(I) + AB(II,I)
11278  75     CONTINUE
11279  50   CONTINUE
11280       IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
11281      &  'PHO_CHAN2A: ABSUM',ABSUM
11282
11283       DO 100 I=1,4
11284         CHI(I)  = 0.D0
11285         CHDS(I) = 0.D0
11286         CHDH(I) = 0.D0
11287         CHDA(I) = 0.D0
11288         CHDB(I) = 0.D0
11289         CHDD(I) = 0.D0
11290         CHDPE(I) = 0.D0
11291         CHDPA(I) = 0.D0
11292         CHDPB(I) = 0.D0
11293         CHDPD(I) = 0.D0
11294         AMPELA(I,0) = 0.D0
11295         AMPELA(I,9) = 0.D0
11296         DO 200 K=1,4
11297           AMPELA(I,K) = 0.D0
11298           AMPELA(I,K+4) = 0.D0
11299           AMPVM(I,K)  = 0.D0
11300           CHI(I)  = CHI(I)  + CHIFAC(K,I)*ABSUM(K)
11301           CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
11302           CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
11303           CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
11304           CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
11305           CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
11306           CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
11307           CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
11308           CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
11309           CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
11310  200    CONTINUE
11311         IF(CHI(I).LT.-DEPS) THEN
11312           IF(IDEB(86).GE.0) THEN
11313             WRITE(LO,'(1X,A,I3,2E12.3)')
11314      &        'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
11315             WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
11316           ENDIF
11317         ENDIF
11318         IF(ABS(CHI(I)).GT.200.D0) THEN
11319           EX1CHI(I) = 0.D0
11320           EX2CHI(I) = 0.D0
11321         ELSE
11322           TMP       = EXP(-CHI(I))
11323           EX1CHI(I) = TMP
11324           EX2CHI(I) = TMP*TMP
11325         ENDIF
11326  100  CONTINUE
11327       IF(IDEB(86).GE.20) THEN
11328         WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
11329       ENDIF
11330
11331       AMPELA(1,0) = 4.D0
11332       DO 300 K=1,4
11333         DO 400 J=1,4
11334           CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
11335           AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
11336           AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
11337           AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
11338           AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
11339           AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
11340           AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
11341           AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
11342           AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
11343           AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
11344           AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
11345  400    CONTINUE
11346  300  CONTINUE
11347
11348       IF(IDEB(86).GE.25) THEN
11349         DO 305 I=1,9
11350           WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
11351      &      (AMPELA(K,1),K=1,4)
11352  305    CONTINUE
11353       ENDIF
11354
11355 C  VDM factors --> amplitudes
11356 C  low mass excitations
11357       DO 500 I=1,4
11358         AMPCHA(I) = 0.D0
11359         DO 600 K=1,4
11360           AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
11361  600    CONTINUE
11362  500  CONTINUE
11363       AMPVME    = AMPCHA(1)/EIGHT
11364       AMLMSD(1) = AMPCHA(2)/EIGHT
11365       AMLMSD(2) = AMPCHA(3)/EIGHT
11366       AMLMDD    = AMPCHA(4)/EIGHT
11367 C  elastic part, high mass diffraction
11368       AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
11369       AMPSOF    = 0.D0
11370       AMPHAR    = 0.D0
11371       AMHMSD(1) = 0.D0
11372       AMHMSD(2) = 0.D0
11373       AMHMDD    = 0.D0
11374       AMPDP(1)  = 0.D0
11375       AMPDP(2)  = 0.D0
11376       AMPDP(3)  = 0.D0
11377       AMPDP(4)  = 0.D0
11378       DO 450 I=1,4
11379         AMPEL     = AMPEL     + ELAFAC(I)*AMPELA(I,0)/8.D0
11380         AMPSOF    = AMPSOF    + ELAFAC(I)*AMPELA(I,1)
11381         AMPHAR    = AMPHAR    + ELAFAC(I)*AMPELA(I,2)
11382         AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
11383         AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
11384         AMHMDD    = AMHMDD    + ELAFAC(I)*AMPELA(I,5)
11385         AMPDP(1)  = AMPDP(1)  + ELAFAC(I)*AMPELA(I,6)
11386         AMPDP(2)  = AMPDP(2)  + ELAFAC(I)*AMPELA(I,7)
11387         AMPDP(3)  = AMPDP(3)  + ELAFAC(I)*AMPELA(I,8)
11388         AMPDP(4)  = AMPDP(4)  + ELAFAC(I)*AMPELA(I,9)
11389  450  CONTINUE
11390       AMPSOF    = AMPSOF/16.D0
11391       AMPHAR    = AMPHAR/16.D0
11392       AMHMSD(1) = AMHMSD(1)/16.D0
11393       AMHMSD(2) = AMHMSD(2)/16.D0
11394       AMHMDD    = AMHMDD/16.D0
11395       AMPDP(1)  = AMPDP(1)/16.D0
11396       AMPDP(2)  = AMPDP(2)/16.D0
11397       AMPDP(3)  = AMPDP(3)/16.D0
11398       AMPDP(4)  = AMPDP(4)/16.D0
11399       IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
11400       IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
11401       IF(DREAL(AMHMDD).LE.0.D0)    AMHMDD = 0.D0
11402       IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
11403       IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
11404       IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
11405       IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
11406
11407 C  vector-meson production, weight factors
11408       IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
11409         IF(IFPAP(1).EQ.22) THEN
11410           IF(IFPAP(2).EQ.22) THEN
11411             DO 10 I=1,4
11412               DO 15 J=1,4
11413                 AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
11414  15           CONTINUE
11415  10         CONTINUE
11416           ELSE
11417             AMPVM(1,1) = PARMDL(10)*AMPVME
11418             AMPVM(2,1) = PARMDL(11)*AMPVME
11419             AMPVM(3,1) = PARMDL(12)*AMPVME
11420             AMPVM(4,1) = PARMDL(13)*AMPVME
11421           ENDIF
11422         ELSE IF(IFPAP(2).EQ.22) THEN
11423           AMPVM(1,1) = PARMDL(10)*AMPVME
11424           AMPVM(1,2) = PARMDL(11)*AMPVME
11425           AMPVM(1,3) = PARMDL(12)*AMPVME
11426           AMPVM(1,4) = PARMDL(13)*AMPVME
11427         ENDIF
11428       ENDIF
11429 C  debug output
11430       IF(IDEB(86).GE.5) THEN
11431         WRITE(LO,'(/,1X,A)')
11432      &    'PHO_CHAN2A: impact parameter amplitudes'
11433         WRITE(LO,'(1X,A,1P,2E12.3)') '       AMPEL',AMPEL
11434         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
11435         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
11436         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
11437         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
11438         WRITE(LO,'(1X,A,1P,4E12.3)') '  AMPSOF/HAR',AMPSOF,AMPHAR
11439         WRITE(LO,'(1X,A,1P,4E12.3)') '      AMLMSD',AMLMSD
11440         WRITE(LO,'(1X,A,1P,4E12.3)') '      AMHMSD',AMHMSD
11441         WRITE(LO,'(1X,A,1P,2E12.3)') '      AMLMDD',AMLMDD
11442         WRITE(LO,'(1X,A,1P,2E12.3)') '      AMHMDD',AMHMDD
11443         WRITE(LO,'(1X,A,1P,8E10.3)') '  AMPDP(1-4)',AMPDP
11444       ENDIF
11445
11446       END
11447
11448 *$ CREATE PHO_EVENT.FOR
11449 *COPY PHO_EVENT
11450 CDECK  ID>, PHO_EVENT
11451       SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
11452 C********************************************************************
11453 C
11454 C     main subroutine to manage simulation processes
11455 C
11456 C     input: NEV       -1   initialization
11457 C                       1   generation of events
11458 C                       2   generation of events without rejection
11459 C                           due to energy dependent cross section
11460 C                       3   generation of events without rejection
11461 C                           using initialization energy
11462 C                      -2   output of event generation statistics
11463 C            P1(4)     momentum of particle 1 (internal TARGET)
11464 C            P2(4)     momentum of particle 2 (internal PROJECTILE)
11465 C            FAC       used for initialization:
11466 C                      contains cross section the events corresponds to
11467 C                      during generation: current cross section
11468 C
11469 C     output: IREJ     0: event accepted
11470 C                      1: event rejected
11471 C
11472 C********************************************************************
11473       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11474       SAVE
11475
11476       PARAMETER ( TINY   =  1.D-10 )
11477
11478       DIMENSION P1(4),P2(4)
11479
11480 C  input/output channels
11481       INTEGER LI,LO
11482       COMMON /POINOU/ LI,LO
11483 C  event debugging information
11484       INTEGER NMAXD
11485       PARAMETER (NMAXD=100)
11486       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11487      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11488       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11489      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11490 C  model switches and parameters
11491       CHARACTER*8 MDLNA
11492       INTEGER ISWMDL,IPAMDL
11493       DOUBLE PRECISION PARMDL
11494       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11495 C  general process information
11496       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11497       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11498 C  internal rejection counters
11499       INTEGER NMXJ
11500       PARAMETER (NMXJ=60)
11501       CHARACTER*10 REJTIT
11502       INTEGER IFAIL
11503       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11504 C  gamma-lepton or gamma-hadron vertex information
11505       INTEGER IGHEL,IDPSRC,IDBSRC
11506       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
11507      &                 RADSRC,AMSRC,GAMSRC
11508       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
11509      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
11510      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
11511 C  global event kinematics and particle IDs
11512       INTEGER IFPAP,IFPAB
11513       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11514       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11515 C  cross sections
11516       INTEGER IPFIL,IFAFIL,IFBFIL
11517       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11518      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11519      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11520      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11521      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11522       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11523      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11524      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11525      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11526      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11527      &                IPFIL,IFAFIL,IFBFIL
11528 C  event weights and generated cross section
11529       INTEGER IPOWGC,ISWCUT,IVWGHT
11530       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11531       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11532      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11533 C  names of hard scattering processes
11534       INTEGER Max_pro_1
11535       PARAMETER ( Max_pro_1 = 16 )
11536       CHARACTER*18 PROC
11537       COMMON /POHPRO/ PROC(0:Max_pro_1)
11538 C  hard cross sections and MC selection weights
11539       INTEGER Max_pro_2
11540       PARAMETER ( Max_pro_2 = 16 )
11541       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
11542      &  MH_acc_1,MH_acc_2
11543       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
11544       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
11545      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
11546      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
11547      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
11548      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
11549 C  table of particle indices for recursive PHOJET calls
11550       INTEGER MAXIPX
11551       PARAMETER ( MAXIPX = 100 )
11552       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11553       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11554      &                IPOIX1,IPOIX2,IPOIX3
11555
11556       DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
11557
11558       IREJ = 0
11559
11560 C  initializations
11561       IF(NEV.EQ.-1) THEN
11562         WRITE(LO,'(/3(/1X,A))')
11563      &    '=======================================================',
11564      &    '  ------- initialization of event generation --------',
11565      &    '======================================================='
11566         CALL PHO_SETMDL(0,0,-2)
11567 C  amplitude parameters
11568         CALL PHO_FITPAR(1)
11569
11570         CALL PHO_REJSTA(-1)
11571 C  initialize MC package
11572         CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
11573         CALL PHO_MCINI
11574         CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11575      &    0.D0,-1)
11576         CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
11577
11578 C  cross section
11579         FAC = SIGGEN(4)
11580         DO 20 I=1,10
11581           IPRSAM(I) = 0
11582           IPRACC(I) = 0
11583           IENACC(I) = 0
11584  20     CONTINUE
11585         ISPS = 0
11586         ISPA = 0
11587         ISRS = 0
11588         ISRA = 0
11589         IHPS = 0
11590         IHPA = 0
11591         ISTS = 0
11592         ISTA = 0
11593         ISLS = 0
11594         ISLA = 0
11595         IDIS = 0
11596         IDIA = 0
11597         IDPS = 0
11598         IDPA = 0
11599         IDNS(1) = 0
11600         IDNS(2) = 0
11601         IDNS(3) = 0
11602         IDNS(4) = 0
11603         IDNA(1) = 0
11604         IDNA(2) = 0
11605         IDNA(3) = 0
11606         IDNA(4) = 0
11607         KACCEP = 0
11608         KEVENT = 0
11609         KEVGEN = 0
11610         ECMSUM = 0.D0
11611       ELSE IF(NEV.GT.0) THEN
11612 C
11613 C  -------------- begin event generation ---------------
11614 C
11615         IPAMDL(13) = 0
11616         IF(NEV.EQ.3) IPAMDL(13) = 1
11617         KEVENT = KEVENT+1
11618 C  enable debugging
11619         CALL PHO_TRACE(0,0,0)
11620         IF(IDEB(68).GE.2) THEN
11621           IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
11622      &      WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11623         ENDIF
11624         CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
11625 C  cross section calculation
11626         FAC = SIGGEN(3)
11627         IF(NEV.EQ.1) THEN
11628           IF(IVWGHT(1).EQ.1) THEN
11629             WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
11630           ELSE
11631             WG = SIGGEN(3)/SIGGEN(4)
11632           ENDIF
11633           IF(DT_RNDM(FAC).GT.WG) THEN
11634             IREJ = 1
11635             IF(IDEB(68).GE.6) THEN
11636               WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
11637      &          'PHO_EVENT: rejection due to cross section',
11638      &          ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
11639      &          KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
11640               CALL PHO_PREVNT(-1)
11641             ENDIF
11642             RETURN
11643           ENDIF
11644         ENDIF
11645         KEVGEN = KEVGEN+1
11646         SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
11647         HSWGHT(0) = MAX(1.D0,WG)
11648
11649         ITRY1 = 0
11650  50     CONTINUE
11651           ITRY1 = ITRY1+1
11652           IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11653
11654 C  sample process
11655           IPROCE = 0
11656           CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11657      &      1.D0,IPROCE)
11658           IF(IPROCE.EQ.0) THEN
11659             IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
11660      &        'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
11661             IREJ = 50
11662             RETURN
11663           ENDIF
11664 C  sampling statistics
11665           IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
11666
11667           ITRY2 = 0
11668  60       CONTINUE
11669             ITRY2 = ITRY2+1
11670             IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11671 C  sample number of cut graphs according to IPROCE and
11672 C  generate parton configurations+strings
11673             CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
11674 C  collect statistics
11675             ISPS = ISPS+KSPOM
11676             IHPS = IHPS+KHPOM
11677             ISRS = ISRS+KSREG
11678             ISTS = ISTS+KSTRG+KHTRG
11679             ISLS = ISLS+KSLOO+KHLOO
11680             IDIS = IDIS+MIN(KHDIR,1)
11681             IDPS = IDPS+KHDPO+KSDPO
11682             IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
11683      &        IDNS(KHDIR) = IDNS(KHDIR)+1
11684 C  rejection?
11685           IF(IREJ.NE.0) THEN
11686             IF(IDEB(68).GE.4) THEN
11687               WRITE(LO,'(/1X,A,2I5)')
11688      &          'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
11689               CALL PHO_PREVNT(-1)
11690             ENDIF
11691             IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
11692               RETURN
11693             ENDIF
11694             IFAIL(1) = IFAIL(1)+1
11695             IF(ITRY1.GT.5) RETURN
11696             IF(IREJ.GE.5) THEN
11697               IF(ISWMDL(2).EQ.0) RETURN
11698               GOTO 50
11699             ENDIF
11700             IF(ITRY2.LT.5) GOTO 60
11701             GOTO 50
11702           ENDIF
11703 C  fragmentation of strings
11704
11705 C  FSR and string fragmentation is done separately by DPMJET routines
11706 C         CALL PHO_STRFRA(IREJ)
11707
11708 C  rejection?
11709           IF(IREJ.NE.0) THEN
11710             IFAIL(23) = IFAIL(23)+1
11711             IF(IDEB(68).GE.4)  THEN
11712               WRITE(LO,'(/1X,A,2I5)')
11713      &          'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
11714               CALL PHO_PREVNT(-1)
11715             ENDIF
11716             GOTO 50
11717           ENDIF
11718 C  check of conservation of quantum numbers
11719           IF(IDEB(68).GE.-5) THEN
11720             CALL PHO_CHECK(-1,IREJ)
11721             IF(IREJ.NE.0) GOTO 50
11722           ENDIF
11723 C  event now completely processed and accepted
11724 C  acceptance statistics
11725           IPRACC(IPROCE) = IPRACC(IPROCE)+1
11726           ISPA = ISPA+KSPOM
11727           IHPA = IHPA+KHPOM
11728           ISRA = ISRA+KSREG
11729           ISTA = ISTA+(KSTRG+KHTRG)
11730           ISLA = ISLA+(KSLOO+KHLOO)
11731           IDIA = IDIA+MIN(KHDIR,1)
11732           IDPA = IDPA+KHDPO+KSDPO
11733           IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
11734      &      IDNA(KHDIR) = IDNA(KHDIR)+1
11735           DO 55 I=1,IPOIX2
11736             IENACC(IPORES(I)) = IENACC(IPORES(I))+1
11737  55       CONTINUE
11738           KACCEP = KACCEP+1
11739
11740 C  debug output (partial / full event listing)
11741           if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
11742      &      WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11743           IF(IDEB(67).GE.10) THEN
11744             IF(IDEB(67).LE.15) THEN
11745               CALL PHO_PREVNT(-1)
11746             ELSE IF(IDEB(67).LE.20) THEN
11747               CALL PHO_PREVNT(0)
11748             ELSE IF(IDEB(67).LE.25) THEN
11749               CALL PHO_PREVNT(1)
11750             ELSE
11751               CALL PHO_PREVNT(2)
11752             ENDIF
11753           ENDIF
11754 C
11755 C  effective weight
11756           DO 65 I=1,10
11757             IF(IPOWGC(I).GT.0) THEN
11758               HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
11759             ENDIF
11760  65       CONTINUE
11761           IF(IVWGHT(1).EQ.1) THEN
11762             WG = HSWGHT(0)
11763             IF(WG.GT.1.01D0) THEN
11764               IF(EVWGHT(1).LT.1.01D0) THEN
11765                 WRITE(LO,'(1X,A,2I12,1PE12.3)')
11766      &            'PHO_EVENT: cross section weight > 1',
11767      &            KEVENT,KACCEP,WG
11768                 WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
11769      &            SIGGEN(3),SIGGEN(4),EVWGHT(1)
11770               ENDIF
11771               EVWGHT(1) = HSWGHT(0)
11772               HSWGHT(0) = 1.D0
11773             ELSE
11774               EVWGHT(1) = 1.D0
11775             ENDIF
11776           ENDIF
11777
11778 C  effective cross section
11779           SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
11780           ECMSUM = ECMSUM+ECM
11781           SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
11782       ELSE IF(NEV.EQ.-2) THEN
11783
11784 C  ---------------- end of event generation ----------------------
11785
11786         WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
11787      &    '====================================================',
11788      &    '  --------- summary of event generation ----------',
11789      &    '====================================================',
11790      &    'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
11791      &    'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
11792
11793 C  write out statistics
11794         IF(KACCEP.GT.0) THEN
11795
11796           FAC1 = SIGGEN(4)/DBLE(KEVENT)
11797           FAC2 = FAC/DBLE(KACCEP)
11798           WRITE(LO,'(/1X,A,/1X,A)')
11799      &      'PHO_EVENT: generated and accepted events',
11800      &      '----------------------------------------'
11801           WRITE(LO,'(3X,A)')
11802      &   'process, sampled, accepted, cross section (internal/external)'
11803           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
11804      &      IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
11805           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
11806      &      IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
11807           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
11808      &      IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
11809           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
11810      &      IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
11811           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
11812      &      IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
11813           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
11814      &      IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
11815           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
11816      &      IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
11817           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all  ',IPRSAM(8),
11818      &      IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
11819           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
11820      &      DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
11821           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
11822      &      DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
11823           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
11824      &      DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
11825           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
11826      &      DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
11827           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
11828      &      DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
11829           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
11830      &      DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
11831           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
11832      &      DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
11833           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
11834      &      DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
11835           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
11836      &      DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
11837           IF(ISWMDL(14).GT.0) THEN
11838             WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
11839      &        ISWMDL(14)
11840             WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
11841             WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
11842             WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
11843             WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
11844             WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
11845           ENDIF
11846           WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
11847      &      SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
11848
11849           CALL PHO_REJSTA(-2)
11850           CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11851      &      0.D0,-2)
11852           CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
11853 C  statistics of hard scattering processes
11854           WRITE(LO,'(2(/1X,A))')
11855      &      'PHO_EVENT: statistics of hard scattering processes',
11856      &      '--------------------------------------------------'
11857           DO 43 K=1,4
11858             IF(MH_tried(0,K).GT.0) THEN
11859               WRITE(LO,'(/5X,A,I3)')
11860      &      'process (accepted,x-section internal/external) for IP:',K
11861               DO 47 M=0,Max_pro_2
11862                 WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
11863      &            MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
11864      &            DBLE(MH_acc_2(M,K))*FAC2
11865  47           CONTINUE
11866             ENDIF
11867  43       CONTINUE
11868
11869         ELSE
11870           WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
11871         ENDIF
11872         WRITE(LO,'(/3(/1X,A)/)')
11873      &    '======================================================',
11874      &    '   ------- end of event generation summary --------',
11875      &    '======================================================'
11876       ELSE
11877         WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
11878       ENDIF
11879
11880       END
11881
11882 *$ CREATE PHO_PARTON.FOR
11883 *COPY PHO_PARTON
11884 CDECK  ID>, PHO_PARTON
11885       SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
11886 C********************************************************************
11887 C
11888 C     calculation of complete parton configuration
11889 C
11890 C     input:  IPROC   process ID  1 nondiffractive
11891 C                                 2 elastic
11892 C                                 3 quasi-ela. rho,omega,phi prod.
11893 C                                 4 double Pomeron
11894 C                                 5 single diff 1
11895 C                                 6 single diff 2
11896 C                                 7 double diff diss.
11897 C                                 8 single-resolved / direct photon
11898 C             JM1,2   index of mother particles in /POEVT1/
11899 C
11900 C
11901 C     output: complete parton configuration in /POEVT1/
11902 C             IREJ                1 failure
11903 C                                 0 success
11904 C                                50 rejection due to user cutoffs
11905 C
11906 C********************************************************************
11907       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11908       SAVE
11909
11910       DIMENSION P1(4),P2(4)
11911
11912       PARAMETER ( TINY   =  1.D-10 )
11913
11914 C  input/output channels
11915       INTEGER LI,LO
11916       COMMON /POINOU/ LI,LO
11917 C  event debugging information
11918       INTEGER NMAXD
11919       PARAMETER (NMAXD=100)
11920       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11921      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11922       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11923      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11924 C  model switches and parameters
11925       CHARACTER*8 MDLNA
11926       INTEGER ISWMDL,IPAMDL
11927       DOUBLE PRECISION PARMDL
11928       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11929 C  table of particle indices for recursive PHOJET calls
11930       INTEGER MAXIPX
11931       PARAMETER ( MAXIPX = 100 )
11932       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11933       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11934      &                IPOIX1,IPOIX2,IPOIX3
11935 C  general process information
11936       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11937       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11938 C  global event kinematics and particle IDs
11939       INTEGER IFPAP,IFPAB
11940       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11941       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11942 C  cross sections
11943       INTEGER IPFIL,IFAFIL,IFBFIL
11944       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11945      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11946      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11947      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11948      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11949       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11950      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11951      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11952      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11953      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11954      &                IPFIL,IFAFIL,IFBFIL
11955 C  event weights and generated cross section
11956       INTEGER IPOWGC,ISWCUT,IVWGHT
11957       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11958       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11959      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11960 C  internal rejection counters
11961       INTEGER NMXJ
11962       PARAMETER (NMXJ=60)
11963       CHARACTER*10 REJTIT
11964       INTEGER IFAIL
11965       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11966
11967       IREJ = 0
11968 C  clear event statistics
11969       KSPOM = 0
11970       KHPOM = 0
11971       KSREG = 0
11972       KHDIR = 0
11973       KSTRG = 0
11974       KHTRG = 0
11975       KSLOO = 0
11976       KHLOO = 0
11977       KHARD = 0
11978       KSOFT = 0
11979       KSDPO = 0
11980       KHDPO = 0
11981
11982 C-------------------------------------------------------------------
11983 C  nondiffractive resolved processes
11984
11985       IF(IPROC.EQ.1) THEN
11986 C  sample number of interactions
11987  555    CONTINUE
11988         IINT = 0
11989         IP   = 1
11990 C  generate only hard events
11991         IF(ISWMDL(2).EQ.0) THEN
11992           MHPOM = 1
11993           MSPOM = 0
11994           MSREG = 0
11995           MHDIR = 0
11996           HSWGHT(1) = 1.D0
11997         ELSE
11998 C  minimum bias events
11999           IPOWGC(1) = 0
12000  10       CONTINUE
12001           CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
12002           IPOWGC(1) = IPOWGC(1)+1
12003           MINT = 0
12004           MHDIR = 0
12005           MSTRG = 0
12006           MSLOO = 0
12007 C
12008 C  resolved soft processes: pomeron and reggeon
12009           MSPOM = IINT
12010           MSREG = JINT
12011 C  resolved hard process: hard pomeron
12012           MHPOM = KINT
12013 C  resolved absorptive corrections
12014           MPTRI = 0
12015           MPLOO = 0
12016 C  restrictions given by user
12017           IF(MSPOM.LT.ISWCUT(1)) GOTO 10
12018           IF(MSREG.LT.ISWCUT(2)) GOTO 10
12019           IF(MHPOM.LT.ISWCUT(3)) GOTO 10
12020           HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
12021 C  ----------------------------
12022           IF(ISWMDL(15).EQ.0) THEN
12023             MHPOM = 0
12024             IF(MSREG.GT.0) THEN
12025               MSPOM = 0
12026               MSREG = 1
12027             ELSE
12028               MSPOM = 1
12029               MSREG = 0
12030             ENDIF
12031           ELSE IF(ISWMDL(15).EQ.1) THEN
12032             IF(MHPOM.GT.0) THEN
12033               MHPOM = 1
12034               MSPOM = 0
12035               MSREG = 0
12036             ELSE IF(MSPOM.GT.0) THEN
12037               MSPOM = 1
12038               MSREG = 0
12039             ELSE
12040               MSREG = 1
12041             ENDIF
12042           ELSE IF(ISWMDL(15).EQ.2) THEN
12043             MHPOM = MIN(1,MHPOM)
12044           ELSE IF(ISWMDL(15).EQ.3) THEN
12045             MSPOM = MIN(1,MSPOM)
12046           ENDIF
12047         ENDIF
12048 C  ----------------------------
12049
12050 C  statistics
12051         ISPS = ISPS+MSPOM
12052         IHPS = IHPS+MHPOM
12053         ISRS = ISRS+MSREG
12054         ISTS = ISTS+MSTRG
12055         ISLS = ISLS+MSLOO
12056
12057         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
12058      &    'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
12059      &    KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
12060
12061         ITRY2 = 0
12062  50     CONTINUE
12063         ITRY2 = ITRY2+1
12064         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12065         KSPOM = MSPOM
12066         KSREG = MSREG
12067         KHPOM = MHPOM
12068         KHDIR = MHDIR
12069         KSTRG = MPTRI
12070         KSLOO = MPLOO
12071
12072         CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12073         IF(IREJ.NE.0) THEN
12074           IF(IREJ.EQ.50) RETURN
12075           IF(IDEB(3).GE.2) THEN
12076             WRITE(LO,'(/1X,A,I5)')
12077      &        'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
12078             CALL PHO_PREVNT(-1)
12079           ENDIF
12080           RETURN
12081         ENDIF
12082         IF(MHPOM.GT.0) THEN
12083           IDNODF = 3
12084         ELSE IF(MSPOM.GT.0) THEN
12085           IDNODF = 2
12086         ELSE
12087           IDNODF = 1
12088         ENDIF
12089 C  check of quantum numbers of parton configurations
12090         IF(IDEB(3).GE.0) THEN
12091           CALL PHO_CHECK(1,IREJ)
12092           IF(IREJ.NE.0) GOTO 50
12093         ENDIF
12094 C  sample strings to prepare fragmentation
12095         CALL PHO_STRING(1,IREJ)
12096         IF(IREJ.NE.0) THEN
12097           IF(IREJ.EQ.50) RETURN
12098           IFAIL(30) = IFAIL(30)+1
12099           IF(IDEB(3).GE.2)  THEN
12100             WRITE(LO,'(/1X,A,I5)')
12101      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12102             CALL PHO_PREVNT(-1)
12103           ENDIF
12104           IF(ITRY2.LT.20) GOTO 50
12105           IF(IDEB(3).GE.1) THEN
12106             WRITE(LO,'(/1X,A,I5)')
12107      &        'PHO_PARTON: rejection',ITRY2
12108             CALL PHO_PREVNT(-1)
12109           ENDIF
12110           RETURN
12111         ENDIF
12112
12113 C  statistics
12114         ISPA = ISPA+KSPOM
12115         IHPA = IHPA+KHPOM
12116         ISRA = ISRA+KSREG
12117         ISTA = ISTA+KSTRG
12118         ISLA = ISLA+KSLOO
12119
12120 C-------------------------------------------------------------------
12121 C  elastic scattering / quasi-elastic rho/omega/phi production
12122
12123       ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12124         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12125      &    'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12126
12127 C  DPMJET call with special projectile / target: transform into CMS
12128         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12129      &    CALL PHO_DFWRAP(1,JM1,JM2)
12130
12131         CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12132
12133         IF(IREJ.NE.0) THEN
12134 C  DPMJET call with special projectile / target: clean up
12135           IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12136      &      CALL PHO_DFWRAP(-2,JM1,JM2)
12137           IF(IDEB(3).GE.2) THEN
12138             WRITE(LO,'(/1X,A,I5)')
12139      &        'PHO_PARTON: rejection by PHO_QELAST',IREJ
12140             CALL PHO_PREVNT(-1)
12141           ENDIF
12142           RETURN
12143         ENDIF
12144
12145 C  DPMJET call with special projectile / target: transform back
12146         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12147      &    CALL PHO_DFWRAP(2,JM1,JM2)
12148
12149 C  prepare possible decays
12150         CALL PHO_STRING(1,IREJ)
12151         IF(IREJ.NE.0) THEN
12152           IF(IREJ.EQ.50) RETURN
12153           IFAIL(30) = IFAIL(30)+1
12154           RETURN
12155         ENDIF
12156
12157 C---------------------------------------------------------------------
12158 C  double Pomeron scattering
12159
12160       ELSE IF(IPROC.EQ.4) THEN
12161         MSOFT = 0
12162         MHARD = 0
12163         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12164      &      'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12165         IDPS = IDPS+1
12166         ITRY2 = 0
12167  60     CONTINUE
12168         ITRY2 = ITRY2+1
12169         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12170 C
12171         CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12172         IF(IREJ.NE.0) THEN
12173           IF(IDEB(3).GE.2) THEN
12174             WRITE(LO,'(/1X,A,I5)')
12175      &        'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12176             CALL PHO_PREVNT(-1)
12177           ENDIF
12178           RETURN
12179         ENDIF
12180 C  check of quantum numbers of parton configurations
12181         IF(IDEB(3).GE.0) THEN
12182           CALL PHO_CHECK(1,IREJ)
12183           IF(IREJ.NE.0) GOTO 60
12184         ENDIF
12185 C  sample strings to prepare fragmentation
12186         CALL PHO_STRING(1,IREJ)
12187         IF(IREJ.NE.0) THEN
12188           IF(IREJ.EQ.50) RETURN
12189           IFAIL(30) = IFAIL(30)+1
12190           IF(IDEB(3).GE.2) THEN
12191             WRITE(LO,'(/1X,A,I5)')
12192      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12193             CALL PHO_PREVNT(-1)
12194           ENDIF
12195           IF(ITRY2.LT.10) GOTO 60
12196           WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12197           CALL PHO_PREVNT(-1)
12198           RETURN
12199         ENDIF
12200         IDPA = IDPA+1
12201
12202 C-----------------------------------------------------------------------
12203 C  single / double diffraction dissociation
12204
12205       ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12206         MSOFT = 0
12207         MHARD = 0
12208         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12209      &    'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12210         IF(IPROC.EQ.5) ID1S = ID1S+1
12211         IF(IPROC.EQ.6) ID2S = ID2S+1
12212         IF(IPROC.EQ.7) ID3S = ID3S+1
12213         ITRY2 = 0
12214  70     CONTINUE
12215         ITRY2 = ITRY2+1
12216         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12217         IPAR1 = 1
12218         IPAR2 = 1
12219         IF(IPROC.EQ.5) IPAR2 = 0
12220         IF(IPROC.EQ.6) IPAR1 = 0
12221 C  calculate rapidity gap survival probability
12222         SPROB = 1.D0
12223         IF(ECM.GT.10.D0) THEN
12224           IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12225             IF(SIGTR1(1).LT.1.D-10) THEN
12226               SPROB = 1.D0
12227             ELSE
12228               SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12229             ENDIF
12230           ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12231             IF(SIGTR2(1).LT.1.D-10) THEN
12232               SPROB = 1.D0
12233             ELSE
12234               SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12235             ENDIF
12236           ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12237             IF(SIGLOO.LT.1.D-10) THEN
12238               SPROB = 1.D0
12239             ELSE
12240               SPROB = SIGHDD/SIGLOO
12241             ENDIF
12242           ENDIF
12243         ENDIF
12244
12245 **sr
12246 * temporary patch, r.e. 8.6.99
12247         SPROB = 1.D0
12248 **
12249
12250 C  DPMJET call with special projectile / target: transform into CMS
12251         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12252      &    CALL PHO_DFWRAP(1,JM1,JM2)
12253
12254         CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12255
12256         IF(IREJ.NE.0) THEN
12257 C  DPMJET call with special projectile / target: clean up
12258           IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12259      &      CALL PHO_DFWRAP(-2,JM1,JM2)
12260           IF(IDEB(3).GE.2) THEN
12261             WRITE(LO,'(/1X,A,I5)')
12262      &        'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12263             CALL PHO_PREVNT(-1)
12264           ENDIF
12265           RETURN
12266         ENDIF
12267
12268 C  DPMJET call with special projectile / target: transform back
12269         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12270      &    CALL PHO_DFWRAP(2,JM1,JM2)
12271
12272 C  check of quantum numbers of parton configurations
12273         IF(IDEB(3).GE.0) THEN
12274           CALL PHO_CHECK(1,IREJ)
12275           IF(IREJ.NE.0) GOTO 70
12276         ENDIF
12277 C  sample strings to prepare fragmentation
12278         CALL PHO_STRING(1,IREJ)
12279         IF(IREJ.NE.0) THEN
12280           IF(IREJ.EQ.50) RETURN
12281           IFAIL(30) = IFAIL(30)+1
12282           IF(IDEB(3).GE.2) THEN
12283             WRITE(LO,'(/1X,A,I5)')
12284      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12285             CALL PHO_PREVNT(-1)
12286           ENDIF
12287           IF(ITRY2.LT.10) GOTO 70
12288           WRITE(LO,'(/1X,A,I5)')
12289      &      'PHO_PARTON: rejection',ITRY2
12290           CALL PHO_PREVNT(-1)
12291           RETURN
12292         ENDIF
12293         IF(IPROC.EQ.5) ID1A = ID1A+1
12294         IF(IPROC.EQ.6) ID2A = ID2A+1
12295         IF(IPROC.EQ.7) ID3A = ID3A+1
12296
12297 C-----------------------------------------------------------------------
12298 C  single / double direct processes
12299
12300       ELSE IF(IPROC.EQ.8) THEN
12301         MSREG = 0
12302         MSPOM = 0
12303         MHPOM = 0
12304         MHDIR = 1
12305         IF(IDEB(3).GE.5) THEN
12306           WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12307         ENDIF
12308         IDIS = IDIS+MHDIR
12309         ITRY2 = 0
12310  80     CONTINUE
12311         ITRY2 = ITRY2+1
12312         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12313         KSPOM = MSPOM
12314         KSREG = MSREG
12315         KHPOM = MHPOM
12316         KHDIR = 4
12317
12318         CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12319         IF(IREJ.NE.0) THEN
12320           IF(IREJ.EQ.50) RETURN
12321           IF(IDEB(3).GE.2) THEN
12322             WRITE(LO,'(/1X,A,I5)')
12323      &        'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12324             CALL PHO_PREVNT(-1)
12325           ENDIF
12326           RETURN
12327         ENDIF
12328         IDNODF = 4
12329 C  check of quantum numbers of parton configurations
12330         IF(IDEB(3).GE.0) THEN
12331           CALL PHO_CHECK(1,IREJ)
12332           IF(IREJ.NE.0) GOTO 80
12333         ENDIF
12334 C  sample strings to prepare fragmentation
12335         CALL PHO_STRING(1,IREJ)
12336         IF(IREJ.NE.0) THEN
12337           IF(IREJ.EQ.50) RETURN
12338           IFAIL(30) = IFAIL(30)+1
12339           IF(IDEB(3).GE.2) THEN
12340             WRITE(LO,'(/1X,A,I5)')
12341      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12342             CALL PHO_PREVNT(-1)
12343           ENDIF
12344           IF(ITRY2.LT.10) GOTO 80
12345           WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12346           CALL PHO_PREVNT(-1)
12347           RETURN
12348         ENDIF
12349         IF(IPROC.EQ.5) ID1A = ID1A+1
12350         IF(IPROC.EQ.6) ID2A = ID2A+1
12351         IF(IPROC.EQ.7) ID3A = ID3A+1
12352         IDIA = IDIA+MHDIR
12353
12354 C-----------------------------------------------------------------------
12355 C  initialize control statistics
12356
12357       ELSE IF(IPROC.EQ.-1) THEN
12358         CALL PHO_SAMPRB(ECM,-1,0,0,0)
12359         CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12360         CALL PHO_SEAFLA(-1,0,0,DUM)
12361         IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12362      &    CALL PHO_QELAST(-1,1,2,0)
12363         ISPS = 0
12364         ISPA = 0
12365         ISRS = 0
12366         ISRA = 0
12367         IHPS = 0
12368         IHPA = 0
12369         ISTS = 0
12370         ISTA = 0
12371         ISLS = 0
12372         ISLA = 0
12373         ID1S = 0
12374         ID1A = 0
12375         ID2S = 0
12376         ID2A = 0
12377         ID3S = 0
12378         ID3A = 0
12379         IDPS = 0
12380         IDPA = 0
12381         IDIS = 0
12382         IDIA = 0
12383         CALL PHO_STRING(-1,IREJ)
12384         CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12385         RETURN
12386
12387 C-----------------------------------------------------------------------
12388 C  produce statistics summary
12389
12390       ELSE IF(IPROC.EQ.-2) THEN
12391         IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12392         IF(IDEB(3).GE.0) THEN
12393           WRITE(LO,'(/1X,A,/1X,A)')
12394      &      'PHO_PARTON: internal statistics on parton configurations',
12395      &      '--------------------------------------------------------'
12396           WRITE(LO,'(5X,A)') 'process          sampled      accepted'
12397           WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12398           WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12399           WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12400           WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12401           WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12402           WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12403           WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12404           WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12405           WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12406           WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12407         ENDIF
12408         CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12409         IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12410      &    CALL PHO_QELAST(-2,1,2,0)
12411         CALL PHO_STRING(-2,IREJ)
12412         CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12413         CALL PHO_SEAFLA(-2,0,0,DUM)
12414         RETURN
12415       ELSE
12416         WRITE(LO,'(1X,A,I2)')
12417      &    'PARTON:ERROR: unknown process ID ',IPROC
12418         STOP
12419       ENDIF
12420
12421       END
12422
12423 *$ CREATE PHO_MCINI.FOR
12424 *COPY PHO_MCINI
12425 CDECK  ID>, PHO_MCINI
12426       SUBROUTINE PHO_MCINI
12427 C********************************************************************
12428 C
12429 C     initialization of MC event generation
12430 C
12431 C********************************************************************
12432       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12433       SAVE
12434
12435       PARAMETER ( PIMASS =  0.13D0,
12436      &            TINY   =  1.D-10 )
12437
12438 C  input/output channels
12439       INTEGER LI,LO
12440       COMMON /POINOU/ LI,LO
12441 C  event debugging information
12442       INTEGER NMAXD
12443       PARAMETER (NMAXD=100)
12444       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12445      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12446       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12447      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12448 C  model switches and parameters
12449       CHARACTER*8 MDLNA
12450       INTEGER ISWMDL,IPAMDL
12451       DOUBLE PRECISION PARMDL
12452       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12453 C  general process information
12454       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12455       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12456 C  cross sections
12457       INTEGER IPFIL,IFAFIL,IFBFIL
12458       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12459      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12460      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12461      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12462      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12463       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12464      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12465      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12466      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12467      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12468      &                IPFIL,IFAFIL,IFBFIL
12469 C  hard cross sections and MC selection weights
12470       INTEGER Max_pro_2
12471       PARAMETER ( Max_pro_2 = 16 )
12472       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12473      &  MH_acc_1,MH_acc_2
12474       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12475       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12476      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12477      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12478      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12479      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12480 C  interpolation tables for hard cross section and MC selection weights
12481       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12482       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12483       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12484       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12485      &  HQ2a_tab,HQ2b_tab,HEcm_tab
12486       COMMON /POHTAB/
12487      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12488      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12489      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12490      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12491      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12492      &  HEcm_tab(1:Max_tab_E,0:4),
12493      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12494 C  global event kinematics and particle IDs
12495       INTEGER IFPAP,IFPAB
12496       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12497       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12498 C  obsolete cut-off information
12499       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12500       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12501 C  event weights and generated cross section
12502       INTEGER IPOWGC,ISWCUT,IVWGHT
12503       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12504       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12505      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12506 C  cut probability distribution
12507       INTEGER IEETA1,IIMAX,KKMAX
12508       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12509       INTEGER IEEMAX,IMAX,KMAX
12510       REAL PROB
12511       DOUBLE PRECISION EPTAB
12512       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12513      &                IEEMAX,IMAX,KMAX
12514 C  energy-interpolation table
12515       INTEGER IEETA2
12516       PARAMETER ( IEETA2 = 20 )
12517       INTEGER ISIMAX
12518       DOUBLE PRECISION SIGTAB,SIGECM
12519       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12520
12521       CHARACTER*15 PHO_PNAME
12522       DIMENSION ECMF(4)
12523
12524       DATA  XMPOM / 0.766D0 /
12525
12526 C  initialize fragmentation
12527       CALL PHO_FRAINI(ISWMDL(6))
12528
12529 C  reset interpolation tables
12530       DO 50 I=1,4
12531         DO 60 J=1,10
12532           DO 70 K=1,70
12533             SIGTAB(I,K,J) = 0.D0
12534  70       CONTINUE
12535           SIGECM(I,J) = 0.D0
12536  60     CONTINUE
12537  50   CONTINUE
12538
12539 C  max. number of allowed colors (large N expansion)
12540       IC1 = 0
12541       IC2 = 10000
12542       CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12543
12544 C  lower energy limit of initialization
12545       ETABLO = PARMDL(19)
12546       IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12547
12548       WRITE(LO,'(/,1X,A,2F12.1)')
12549      &  'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12550       WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12551      &  'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12552      &  PMASS(1),PVIRT(1)
12553       WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12554      &  'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12555      &  PMASS(2),PVIRT(2)
12556
12557 C  cuts on probabilities of multiple interactions
12558       IMAX = MIN(IPAMDL(32),IIMAX)
12559       KMAX = MIN(IPAMDL(33),KKMAX)
12560       AH = 2.D0*PTCUT(1)/ECM
12561       IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12562       KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12563
12564 C  hard interpolation table
12565       ECMF(1) = ECM
12566       ECMF(2) = 0.9D0*ECMF(1)
12567       ECMF(3) = ECMF(2)
12568       ECMF(4) = ECMF(2)
12569       do k=1,4
12570         IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12571         IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12572         IF(ECMF(k).LT.50.D0)  IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12573         IF(ECMF(k).LT.10.D0)  IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12574       enddo
12575
12576 C  initialization of hard scattering for all channels and cutoffs
12577       IF(HSWCUT(5).GT.PARMDL(36))  CALL PHO_HARMCI(-1,ECMF(1))
12578       I0 = 4
12579       IF(ISWMDL(2).EQ.0) I0 = 1
12580       DO 110 I=I0,1,-1
12581         CALL PHO_HARMCI(I,ECMF(I))
12582  110  CONTINUE
12583
12584 C  dimension of interpolation table of cut probabilities
12585       IEEMAX = MIN(IPAMDL(31),IEETA1)
12586       IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12587       IF(ECM.LT.50.D0)  IEEMAX = MIN(IEEMAX,10)
12588       IF(ECM.LT.10.D0)  IEEMAX = MIN(IEEMAX,5)
12589       ISIMAX = IEEMAX
12590
12591 C  calculate probability distribution
12592       I0 = 4
12593       IFT1 = IFPAP(1)
12594       IFT2 = IFPAP(2)
12595       XMT1 = PMASS(1)
12596       XMT2 = PMASS(2)
12597       XVT1 = PVIRT(1)
12598       XVT2 = PVIRT(2)
12599       IF(ISWMDL(2).EQ.0) I0 = 1
12600       DO 150 IP=I0,1,-1
12601       ECMPRO = ECMF(IP)*1.001D0
12602       IF(IP.EQ.4) THEN
12603         IFPAP(1) = 990
12604         IFPAP(2) = 990
12605         PMASS(1) = XMPOM
12606         PMASS(2) = XMPOM
12607         PVIRT(1) = 0.D0
12608         PVIRT(2) = 0.D0
12609       ELSE IF(IP.EQ.3) THEN
12610         IFPAP(1) = IFT2
12611         IFPAP(2) = 990
12612         PMASS(1) = XMT2
12613         PMASS(2) = XMPOM
12614         PVIRT(1) = XVT2
12615         PVIRT(2) = 0.D0
12616       ELSE IF(IP.EQ.2) THEN
12617         IFPAP(1) = IFT1
12618         IFPAP(2) = 990
12619         PMASS(1) = XMT1
12620         PMASS(2) = XMPOM
12621         PVIRT(1) = XVT1
12622         PVIRT(2) = 0.D0
12623       ELSE
12624         IFPAP(1) = IFT1
12625         IFPAP(2) = IFT2
12626         PMASS(1) = XMT1
12627         PMASS(2) = XMT2
12628         PVIRT(1) = XVT1
12629         PVIRT(2) = XVT2
12630       ENDIF
12631       IF(IEEMAX.GT.1) THEN
12632         IF(IP.EQ.1) THEN
12633           ELMIN = LOG(ETABLO)
12634         ELSE
12635           ELMIN = LOG(2.5D0)
12636         ENDIF
12637         EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12638         DO 100 I=1,IEEMAX
12639           ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12640           CALL PHO_PRBDIS(IP,ECMPRO,I)
12641  100    CONTINUE
12642       ELSE
12643         CALL PHO_PRBDIS(IP,ECMPRO,1)
12644       ENDIF
12645
12646 C  debug output of cross section tables
12647       IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12648       IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12649       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12650      &'Table of total cross sections (mb) for particle combination',IP,
12651      &' Ecm    SIGtot  SIGela  SIGine  SIGqel  SIGsd1  SIGsd2  SIGdd',
12652      &'-------------------------------------------------------------'
12653       DO 200 I=1,IEEMAX
12654         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12655      &    SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12656      &    SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12657      &    SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12658      &    SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12659  200  CONTINUE
12660  201  CONTINUE
12661       IF(IDEB(62).GE.2) THEN
12662       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12663      &'Table of partial x-sections (mb) for particle combination',IP,
12664      &' Ecm    SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL  SIGDDH  SIGCDF',
12665      &'--------------------------------------------------------------'
12666       DO 205 I=1,IEEMAX
12667         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12668      &    SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12669      &    SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12670  205  CONTINUE
12671       ENDIF
12672       IF(IDEB(62).GE.2) THEN
12673       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12674      &'Table of born graph x-sections (mb) for particle combination',IP,
12675      &' Ecm    SIGSVDM SIGHRES SIGHDIR SIGTR1  SIGTR2  SIGLOO SIGDPO',
12676      &'-------------------------------------------------------------'
12677       DO 210 I=1,IEEMAX
12678         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12679      &    SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12680      &    SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12681      &    SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12682      &    SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12683      &    +SIGTAB(IP,68,I)
12684  210  CONTINUE
12685       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12686      &'Table of unitarized x-sections (mb) for particle combination',IP,
12687      &' Ecm    SIGSVDM SIGHVDM  SIGTR1  SIGTR2  SIGLOO SIGDPO  SLOPE',
12688      &'-------------------------------------------------------------'
12689       DO 215 I=1,IEEMAX
12690         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12691      &    SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12692      &    SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12693  215  CONTINUE
12694       ENDIF
12695       IF(IDEB(62).GE.1) THEN
12696       WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12697      &'Table of expected average number of cuts in non-diff events:',
12698      &'       for max. number of cuts soft/hard:',IMAX,KMAX,
12699      &' Ecm   PTCUT   SIGNDF   POM-S   POM-H   REG-S',
12700      &'---------------------------------------------'
12701       DO 220 I=1,IEEMAX
12702         WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12703      &    SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12704      &    SIGTAB(IP,76,I)
12705  220  CONTINUE
12706       IF(IP.EQ.1) THEN
12707         WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12708      &  'Table of rapidity gap survival probability (high-mass diff.):',
12709      &  ' Ecm    Spro-sd1     Spro-sd2    Spro-dd    Spro-cd',
12710      &  '---------------------------------------------------'
12711         DO 230 I=1,IEEMAX
12712           IF(SIGECM(IP,I).GT.10.D0) THEN
12713             SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12714      &               -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12715             SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12716      &               -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12717             SPRDD  = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12718      &               +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12719      &               +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12720             SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12721      &               +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12722             WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12723      &        SPRSD1,SPRSD2,SPRDD,SPRCDF
12724           ENDIF
12725  230    CONTINUE
12726       ENDIF
12727       ENDIF
12728       ENDIF
12729  150  CONTINUE
12730
12731 C  simulate only hard scatterings
12732       IF(ISWMDL(2).EQ.0) THEN
12733         WRITE(LO,'(2(/1X,A))')
12734      &    'WARNING: generation of hard scatterings only!',
12735      &    '============================================='
12736         DO 151 I=2,7
12737           IPRON(I,1) = 0
12738  151    CONTINUE
12739         DO 152 K=2,4
12740           DO 153 I=1,15
12741             IPRON(I,K) = 0
12742  153      CONTINUE
12743  152    CONTINUE
12744         SIGGEN(4) = 0.D0
12745         DO 160 I=1,IEEMAX
12746           SIGMAX = 0.D0
12747           IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12748           IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12749           IF(SIGMAX.GT.SIGGEN(4)) THEN
12750             ISIGM = I
12751             SIGGEN(4) = SIGMAX
12752           ENDIF
12753  160    CONTINUE
12754       ELSE
12755         WRITE(LO,'(2(/1X,A))')
12756      &    'activated processes, cross section',
12757      &    '----------------------------------'
12758         WRITE(LO,'(5X,A,I3,2X,3I3)')
12759      &    '  nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12760         WRITE(LO,'(5X,A,I3,2X,3I3)')
12761      &    '            elastic scattering',(IPRON(2,K),K=1,4)
12762         WRITE(LO,'(5X,A,I3,2X,3I3)')
12763      &    'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12764         WRITE(LO,'(5X,A,I3,2X,3I3)')
12765      &    '      double pomeron processes',(IPRON(4,K),K=1,4)
12766         WRITE(LO,'(5X,A,I3,2X,3I3)')
12767      &    ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12768         WRITE(LO,'(5X,A,I3,2X,3I3)')
12769      &    ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12770         WRITE(LO,'(5X,A,I3,2X,3I3)')
12771      &    '    double diffract. processes',(IPRON(7,K),K=1,4)
12772         WRITE(LO,'(5X,A,I3,2X,3I3)')
12773      &    '       direct photon processes',(IPRON(8,K),K=1,4)
12774
12775 C  calculate effective cross section
12776         SIGGEN(4) = 0.D0
12777         DO 165 I=1,IEEMAX
12778           CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12779      &                PVIRT(1),PVIRT(2))
12780           SIGMAX = 0.D0
12781           if(iswmdl(2).ge.1) then
12782             IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12783      &        -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12784      &        -SIGLDD-SIGHDD-SIGDIR
12785             IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12786             IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12787             IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12788             IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12789             IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12790             IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12791             IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12792           else
12793             IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12794             IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12795           endif
12796           IF(SIGMAX.GT.SIGGEN(4)) THEN
12797             ISIGM = I
12798             SIGGEN(4) = SIGMAX
12799           ENDIF
12800  165    CONTINUE
12801       ENDIF
12802
12803 C  debug output
12804       IF(SIGGEN(4).LT.1.D-20) THEN
12805         WRITE(LO,'(//1X,A)')
12806      &  'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12807         STOP
12808       ENDIF
12809       WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12810      &  SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12811       WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12812
12813       END
12814
12815 *$ CREATE PHO_REJSTA.FOR
12816 *COPY PHO_REJSTA
12817 CDECK  ID>, PHO_REJSTA
12818       SUBROUTINE PHO_REJSTA(IMODE)
12819 C********************************************************************
12820 C
12821 C     MC rejection counting
12822 C
12823 C     input IMODE    -1   initialization
12824 C                    -2   output of statistics
12825 C
12826 C********************************************************************
12827
12828       IMPLICIT NONE
12829
12830       SAVE
12831
12832 C  input/output channels
12833       INTEGER LI,LO
12834       COMMON /POINOU/ LI,LO
12835 C  event debugging information
12836       INTEGER NMAXD
12837       PARAMETER (NMAXD=100)
12838       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12839      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12840       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12841      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12842 C  internal rejection counters
12843       INTEGER NMXJ
12844       PARAMETER (NMXJ=60)
12845       CHARACTER*10 REJTIT
12846       INTEGER IFAIL
12847       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12848
12849       INTEGER IMODE
12850
12851       INTEGER I
12852
12853 C  initialization
12854       IF(IMODE.EQ.-1) THEN
12855         DO 100 I=1,NMXJ
12856           IFAIL(I) = 0
12857  100    CONTINUE
12858 C
12859         REJTIT(1)  = 'PARTON ALL'
12860         REJTIT(2)  = 'STDPAR ALL'
12861         REJTIT(3)  = 'STDPAR DPO'
12862         REJTIT(4)  = 'POMSCA ALL'
12863         REJTIT(5)  = 'POMSCA INT'
12864         REJTIT(6)  = 'POMSCA KIN'
12865         REJTIT(7)  = 'DIFDIS ALL'
12866         REJTIT(8)  = 'POSPOM ALL'
12867         REJTIT(9)  = 'HRES.DIF.1'
12868         REJTIT(10) = 'HDIR.DIF.1'
12869         REJTIT(11) = 'HRES.DIF.2'
12870         REJTIT(12) = 'HDIR.DIF.2'
12871         REJTIT(13) = 'DIFDIS INT'
12872         REJTIT(14) = 'HADRON SP2'
12873         REJTIT(15) = 'HADRON SP3'
12874         REJTIT(16) = 'HARDIR ALL'
12875         REJTIT(17) = 'HARDIR INT'
12876         REJTIT(18) = 'HARDIR KIN'
12877         REJTIT(19) = 'MCHECK BAR'
12878         REJTIT(20) = 'MCHECK MES'
12879         REJTIT(21) = 'DIF.DISS.1'
12880         REJTIT(22) = 'DIF.DISS.2'
12881         REJTIT(23) = 'STRFRA ALL'
12882         REJTIT(24) = 'MSHELL CHA'
12883         REJTIT(25) = 'PARTPT SOF'
12884         REJTIT(26) = 'PARTPT HAR'
12885         REJTIT(27) = 'INTRINS KT'
12886         REJTIT(28) = 'HACHEK DIR'
12887         REJTIT(29) = 'HACHEK RES'
12888         REJTIT(30) = 'STRING ALL'
12889         REJTIT(31) = 'POMSCA INT'
12890         REJTIT(32) = 'DIFF SLOPE'
12891         REJTIT(33) = 'GLU2QU ALL'
12892         REJTIT(34) = 'MASCOR ALL'
12893         REJTIT(35) = 'PARCOR ALL'
12894         REJTIT(36) = 'MSHELL PAR'
12895         REJTIT(37) = 'MSHELL ALL'
12896         REJTIT(38) = 'POMCOR ALL'
12897         REJTIT(39) = 'DB-POM KIN'
12898         REJTIT(40) = 'DB-POM ALL'
12899         REJTIT(41) = 'SOFTXX ALL'
12900         REJTIT(42) = 'SOFTXX PSP'
12901
12902 C  write output
12903       ELSE IF(IMODE.EQ.-2) THEN
12904         WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12905      &                             '--------------------------------'
12906         DO 300 I=1,NMXJ
12907           IF(IFAIL(I).GT.0)
12908      &      WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12909  300    CONTINUE
12910       ELSE
12911         WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12912       ENDIF
12913
12914       END
12915
12916 *$ CREATE PHO_POSPOM.FOR
12917 *COPY PHO_POSPOM
12918 CDECK  ID>, PHO_POSPOM
12919       SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12920 C***********************************************************************
12921 C
12922 C     registration of one cut pomeron (soft/semihard)
12923 C
12924 C     input:   IP      particle combination the pomeron belongs to
12925 C              IND1,2  position of X values in /POSOFT/
12926 C                      1 corresponds to a valence-pomeron
12927 C              IGEN    production process of mother particles
12928 C              IPOM    pomeron number
12929 C              KCUT    total number of cut pomerons and reggeons
12930 C
12931 C     output:  ISWAP   exchange of x values
12932 C              IND1,2  increased by the number of partons belonging
12933 C                      to the generated pomeron cut
12934 C              IREJ    success/failure
12935 C
12936 C**********************************************************************
12937       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12938       SAVE
12939
12940       PARAMETER ( DEPS   =  1.D-8 )
12941
12942 C  input/output channels
12943       INTEGER LI,LO
12944       COMMON /POINOU/ LI,LO
12945 C  event debugging information
12946       INTEGER NMAXD
12947       PARAMETER (NMAXD=100)
12948       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12949      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12950       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12951      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12952 C  internal rejection counters
12953       INTEGER NMXJ
12954       PARAMETER (NMXJ=60)
12955       CHARACTER*10 REJTIT
12956       INTEGER IFAIL
12957       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12958 C  model switches and parameters
12959       CHARACTER*8 MDLNA
12960       INTEGER ISWMDL,IPAMDL
12961       DOUBLE PRECISION PARMDL
12962       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12963 C  general process information
12964       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12965       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12966 C  global event kinematics and particle IDs
12967       INTEGER IFPAP,IFPAB
12968       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12969       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12970 C  data of c.m. system of Pomeron / Reggeon exchange
12971       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12972       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12973      &                 SIDP,CODP,SIFP,COFP
12974       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12975      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
12976      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
12977 C  obsolete cut-off information
12978       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12979       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12980 C  energy-interpolation table
12981       INTEGER IEETA2
12982       PARAMETER ( IEETA2 = 20 )
12983       INTEGER ISIMAX
12984       DOUBLE PRECISION SIGTAB,SIGECM
12985       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12986 C  light-cone x fractions and c.m. momenta of soft cut string ends
12987       INTEGER MAXSOF
12988       PARAMETER ( MAXSOF = 50 )
12989       INTEGER IJSI2,IJSI1
12990       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12991       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12992      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12993      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
12994
12995 C  standard particle data interface
12996       INTEGER NMXHEP
12997
12998       PARAMETER (NMXHEP=4000)
12999
13000       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13001       DOUBLE PRECISION PHEP,VHEP
13002       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13003      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13004      &                VHEP(4,NMXHEP)
13005 C  extension to standard particle data interface (PHOJET specific)
13006       INTEGER IMPART,IPHIST,ICOLOR
13007       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13008
13009 C  table of particle indices for recursive PHOJET calls
13010       INTEGER MAXIPX
13011       PARAMETER ( MAXIPX = 100 )
13012       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
13013       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
13014      &                IPOIX1,IPOIX2,IPOIX3
13015
13016       DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
13017
13018       IREJ = 0
13019       ISWAP = 0
13020       JM1 = NPOSP(1)
13021       JM2 = NPOSP(2)
13022       INDX1 = IND1
13023       INDX2 = IND2
13024       EA1 = XS1(IND1)*ECMP/2.D0
13025       EA2 = XS1(IND1+1)*ECMP/2.D0
13026       EB1 = XS2(IND2)*ECMP/2.D0
13027       EB2 = XS2(IND2+1)*ECMP/2.D0
13028       CMASS1 = MIN(EA1,EA2)
13029       CMASS2 = MIN(EB1,EB2)
13030
13031 C  debug output
13032       IF(IDEB(9).GE.20) THEN
13033         WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
13034      &    'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
13035         WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
13036      &    CMASS1,CMASS2
13037       ENDIF
13038
13039 C  flavours
13040       IF(IND1.EQ.1) THEN
13041         CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
13042       ELSE
13043         CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
13044       ENDIF
13045       IF(IND2.EQ.1) THEN
13046         CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
13047       ELSE
13048         CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
13049       ENDIF
13050       DO 75 I=1,4
13051         P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
13052         P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
13053  75   CONTINUE
13054
13055 C  pomeron resolved?
13056       IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
13057 C  find energy for cross section calculation
13058         IF(IPAMDL(16).EQ.2) THEN
13059           ESUB = ECMP
13060         ELSE IF(IPAMDL(16).EQ.3) THEN
13061           IF(IPROCE.EQ.1) THEN
13062             ESUB = ECM
13063           ELSE
13064             ESUB = ECMP
13065           ENDIF
13066         ELSE
13067           ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
13068      &                -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
13069         ENDIF
13070 C  load cross sections from interpolation table
13071         IF(ESUB.LE.SIGECM(IP,1)) THEN
13072           I1 = 1
13073           I2 = 2
13074         ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
13075           DO 50 I=2,ISIMAX
13076             IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
13077  50       CONTINUE
13078  200      CONTINUE
13079           I1 = I-1
13080           I2 = I
13081         ELSE
13082           WRITE(LO,'(/1X,A,2E12.3)')
13083      &      'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
13084           CALL PHO_PREVNT(-1)
13085           I1 = ISIMAX-1
13086           I2 = ISIMAX
13087         ENDIF
13088         FAC2=0.D0
13089         IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
13090      &                    /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
13091         FAC1=1.D0-FAC2
13092 C  calculate weights
13093 *       WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13094 *       WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13095 *       WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13096 *       WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13097 *       WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13098 *       WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13099
13100         WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13101      &          +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13102         WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13103         WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13104         WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13105      &                 +SIGTAB(IP,64,I2))
13106      &          +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13107      &                 +SIGTAB(IP,64,I1))
13108         WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13109      &                 +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13110      &          +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13111      &                 +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13112
13113 C  one-pomeron cut
13114         WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13115 C  central diff. cut
13116         WGX(2) = WGXCDF
13117 C  diff. diss. of particle 1
13118         WGX(3) = WGXHSD(1)
13119 C  diff. diss. of particle 2
13120         WGX(4) = WGXHSD(2)
13121 C  double diff. dissociation
13122         WGX(5) = WGXHDD
13123 C  two-pomeron cut
13124         WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13125
13126 *       IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13127 *         WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13128 *    &      ' unitarity bound reached for ',IP,ESUB,WGX(1)
13129 *         WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13130 *         WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13131 *         WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13132 *       ENDIF
13133
13134         SUM  = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13135
13136 C  selection loop
13137  205    CONTINUE
13138         XI = DT_RNDM(SUM)*SUM
13139         I = 0
13140         SUM = 0.D0
13141  210    CONTINUE
13142           I = I+1
13143           SUM = SUM+WGX(I)
13144         IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13145 C  phase space correction
13146         IF(I.NE.1) THEN
13147           ISAM = 4
13148           IF(I.EQ.6) ISAM = 8
13149           PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13150 *         IF(DT_RNDM(SUM).GT.PACC) I=1
13151           IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13152         ENDIF
13153
13154 C  do not generate diffraction for events with only one cut pomeron
13155         IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13156
13157 C  do not generate recursive calls for remants with
13158 C  diquark-anti-diquark flavour contents
13159         if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13160         if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13161
13162 C  debug output
13163         IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13164      &    'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13165
13166         IF(I.GT.1) THEN
13167 C  second scattering needed
13168           CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13169           CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13170           IDPD1 = IPHO_ID2PDG(IDHA1)
13171           IDPD2 = IPHO_ID2PDG(IDHA2)
13172
13173           if(INDX1.eq.1) then
13174             if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13175      &        IGEN_had = IGEN
13176           else
13177             IGEN_had = -IGEN
13178           endif
13179           CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13180      &      IPOM,IGEN_had,0,0,IPOS1,1)
13181
13182           if(INDX2.eq.1) then
13183             if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13184      &        IGEN_had = IGEN
13185           else
13186             IGEN_had = -IGEN
13187           endif
13188           CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13189      &      IPOM,IGEN_had,0,0,IPOS1,1)
13190
13191           IND1 = IND1+2
13192           IND2 = IND2+2
13193 C  update index
13194           IPOIX2 = IPOIX2+1
13195
13196           IF(IPOIX2.GT.MAXIPX) THEN
13197             WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13198      &        '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13199             IREJ = 1
13200             RETURN
13201           ENDIF
13202
13203           IPORES(IPOIX2) = I+2
13204           IPOPOS(1,IPOIX2) = IPOS1-1
13205           IPOPOS(2,IPOIX2) = IPOS1
13206           RETURN
13207         ENDIF
13208       ENDIF
13209
13210  100  CONTINUE
13211       IF(ISWMDL(12).EQ.0) THEN
13212 C  sample colors
13213         CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13214         CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13215
13216 C  purely gluonic pomeron or sea strings formed by gluons
13217
13218         IF(    ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13219      &     .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13220           IFLA1 = 21
13221           IFLA2 = 21
13222         ENDIF
13223         IF(    ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13224      &     .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13225           IFLB1 = 21
13226           IFLB2 = 21
13227         ENDIF
13228
13229 C  color connection
13230         IF(IFLA1.NE.21) THEN
13231           IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13232      &      .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13233      &      CALL PHO_SWAPI(ICA1,ICD1)
13234         ENDIF
13235         IF(IFLB1.NE.21) THEN
13236           IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13237      &      .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13238      &      CALL PHO_SWAPI(ICB1,ICC1)
13239         ENDIF
13240         ISWAP = 0
13241         IF(ICA1*ICB1.GT.0) THEN
13242           IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13243             IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13244               CALL PHO_SWAPI(IFLA1,IFLA2)
13245               CALL PHO_SWAPI(ICA1,ICD1)
13246             ELSE
13247               CALL PHO_SWAPI(IFLB1,IFLB2)
13248               CALL PHO_SWAPI(ICB1,ICC1)
13249             ENDIF
13250           ELSE IF(IND1.NE.1) THEN
13251             CALL PHO_SWAPI(IFLA1,IFLA2)
13252             CALL PHO_SWAPI(ICA1,ICD1)
13253           ELSE IF(IND2.NE.1) THEN
13254             CALL PHO_SWAPI(IFLB1,IFLB2)
13255             CALL PHO_SWAPI(ICB1,ICC1)
13256           ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13257             IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13258               CALL PHO_SWAPI(IFLA1,IFLA2)
13259               CALL PHO_SWAPI(ICA1,ICD1)
13260             ELSE
13261               CALL PHO_SWAPI(IFLB1,IFLB2)
13262               CALL PHO_SWAPI(ICB1,ICC1)
13263             ENDIF
13264           ELSE IF(IFLA1.EQ.-IFLA2) THEN
13265             CALL PHO_SWAPI(IFLA1,IFLA2)
13266             CALL PHO_SWAPI(ICA1,ICD1)
13267           ELSE IF(IFLB1.EQ.-IFLB2) THEN
13268             CALL PHO_SWAPI(IFLB1,IFLB2)
13269             CALL PHO_SWAPI(ICB1,ICC1)
13270           ELSE
13271             ISWAP = 1
13272             IF(IDEB(9).GE.5) THEN
13273               WRITE(LO,'(1X,A,I12)')
13274      &          'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13275                 WRITE(LO,'(5X,A,4I7)')
13276      &          'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13277               WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13278             ENDIF
13279           ENDIF
13280         ENDIF
13281
13282 C  registration
13283
13284 C  purely gluonic pomeron or sea strings formed by gluons
13285         IF(IFLA1.EQ.21) THEN
13286           CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13287      &      IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13288           IND1 = IND1+2
13289
13290 C  strings formed by quarks
13291         ELSE
13292 C  valence quark labels
13293           IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13294      &       .and.(IDHEP(JM1).NE.990)) THEN
13295             ICA2 = 1
13296             ICD2 = 1
13297           ENDIF
13298 C  registration
13299           CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13300      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13301      &      ICA2,IPOS1,1)
13302           IND1 = IND1+1
13303           CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13304      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13305      &      ICD2,IPOS,1)
13306           IND1 = IND1+1
13307
13308         ENDIF
13309
13310 C  purely gluonic pomeron or sea strings formed by gluons
13311         IF(IFLB1.EQ.21) THEN
13312           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13313      &      IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13314           IND2 = IND2+2
13315
13316 C  strings formed by quarks
13317         ELSE
13318 C  valence quark labels
13319           IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13320      &       .and.(IDHEP(JM2).NE.990)) THEN
13321             ICB2 = 1
13322             ICC2 = 1
13323           ENDIF
13324 C  registration
13325           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13326      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13327      &      ICB2,IPOS,1)
13328           IND2 = IND2+1
13329           CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13330      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13331      &      ICC2,IPOS2,1)
13332           IND2 = IND2+1
13333
13334         ENDIF
13335
13336 C  soft pt assignment
13337         IF(ISWMDL(18).EQ.0) THEN
13338           CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13339           IF(IREJ.NE.0) THEN
13340             IFAIL(25) = IFAIL(25)+1
13341             RETURN
13342           ENDIF
13343         ENDIF
13344       ELSE
13345 *       CALL PHO_BFKL(P1,P2,IPART,IREJ)
13346 *       IF(IREJ.NE.0) RETURN
13347       ENDIF
13348
13349       END
13350
13351 *$ CREATE PHO_HADSP2.FOR
13352 *COPY PHO_HADSP2
13353 CDECK  ID>, PHO_HADSP2
13354       SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13355 C***********************************************************************
13356 C
13357 C     split hadron momentum XMAX into two partons using
13358 C     lower cut-off: AS
13359 C
13360 C     input:   IFLB    compressed particle code of particle to split
13361 C              XS1     sum of x values already selected
13362 C              XMAX    maximal x possible
13363 C
13364 C     output:  XS1     new sum of x values (without first one)
13365 C              XSOFT1  field of selected x values
13366 C
13367 C**********************************************************************
13368       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13369       SAVE
13370
13371       PARAMETER ( DEPS   =  1.D-8 )
13372
13373       DIMENSION XSOFT1(50)
13374
13375 C  input/output channels
13376       INTEGER LI,LO
13377       COMMON /POINOU/ LI,LO
13378 C  event debugging information
13379       INTEGER NMAXD
13380       PARAMETER (NMAXD=100)
13381       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13382      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13383       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13384      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13385 C  internal rejection counters
13386       INTEGER NMXJ
13387       PARAMETER (NMXJ=60)
13388       CHARACTER*10 REJTIT
13389       INTEGER IFAIL
13390       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13391 C  data on most recent hard scattering
13392       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13393       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13394      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13395      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13396       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13397      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13398      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13399      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13400      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13401
13402 C  model exponents
13403       DATA PVMES1 /-0.5D0/
13404       DATA PVMES2 /-0.5D0/
13405       DATA PVBAR1 / 1.5D0/
13406       DATA PVBAR2 /-0.5D0/
13407 C
13408       IREJ = 0
13409       ITMAX = 100
13410 C
13411 C  mesonic particle
13412       IF(ipho_bar3(IFLB,0).EQ.0) THEN
13413         XPOT1 = PVMES1+1.D0
13414         XPOT2 = PVMES2+1.D0
13415 C  baryonic particle
13416       ELSE
13417         XPOT1 = PVBAR1+1.D0
13418         XPOT2 = PVBAR2+1.D0
13419       ENDIF
13420       ITER = 0
13421       XREST= 1.D0-XS1
13422 C  selection loop
13423  100  CONTINUE
13424         ITER = ITER+1
13425         IF(ITER.GE.ITMAX) THEN
13426           IF(IDEB(39).GE.3) THEN
13427             WRITE(LO,'(1X,A,I8)')
13428      &        'PHO_HADSP2: REJECTION (ITER)',ITER
13429             WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13430           ENDIF
13431           IFAIL(14) = IFAIL(14)+1
13432           IREJ = 1
13433           RETURN
13434         ENDIF
13435         ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13436       IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13437       XSS1 = XS1 + ZZ
13438       IF((1.D0-XSS1).LT.AS) GOTO 100
13439 C
13440       XS1 = XSS1
13441       XSOFT1(1) = 1.D0-XSS1
13442       XSOFT1(2) = ZZ
13443 C  debug output
13444       IF(IDEB(39).GE.10) THEN
13445         WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13446         WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS  X1,X2:',
13447      &    XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13448       ENDIF
13449       END
13450
13451 *$ CREATE PHO_HADSP3.FOR
13452 *COPY PHO_HADSP3
13453 CDECK  ID>, PHO_HADSP3
13454       SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13455 C***********************************************************************
13456 C
13457 C     split hadron momentum XMAX into diquark & quark pair
13458 C     using lower cut-off: AS
13459 C
13460 C     input:   IFLB    compressed particle code of particle to split
13461 C              XS1     sum of x values already selected
13462 C              XMAX    maximal x possible
13463 C
13464 C     output:  XS1     new sum of x values
13465 C              XSOFT1  field of selected x values
13466 C
13467 C
13468 C**********************************************************************
13469       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13470       SAVE
13471       PARAMETER ( DEPS   =  1.D-8 )
13472
13473       DIMENSION XSOFT1(50),XSOFT2(50)
13474
13475 C  input/output channels
13476       INTEGER LI,LO
13477       COMMON /POINOU/ LI,LO
13478 C  event debugging information
13479       INTEGER NMAXD
13480       PARAMETER (NMAXD=100)
13481       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13482      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13483       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13484      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13485 C  internal rejection counters
13486       INTEGER NMXJ
13487       PARAMETER (NMXJ=60)
13488       CHARACTER*10 REJTIT
13489       INTEGER IFAIL
13490       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13491 C  data of c.m. system of Pomeron / Reggeon exchange
13492       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13493       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13494      &                 SIDP,CODP,SIFP,COFP
13495       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13496      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
13497      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
13498
13499       DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13500
13501 C  model exponents
13502       DATA PVMES1 /-0.5D0/
13503       DATA PVMES2 /-0.5D0/
13504       DATA PSMES  /-0.99D0/
13505       DATA PVBAR1 / 1.5D0/
13506       DATA PVBAR2 /-0.5D0/
13507       DATA PSBAR  /-0.99D0/
13508 C
13509       IREJ = 0
13510 C
13511 C  determine exponents
13512 C  particle 1
13513 C
13514       XMMIN = 0.3D0/ECMP
13515       XBMIN = 1.6D0/ECMP
13516 C  mesonic particle
13517       IF(ipho_bar3(IFLB,0).EQ.0) THEN
13518         XPOT1(1) = PVMES1
13519         XMIN(1,1)  = XMMIN
13520         XPOT1(2) = PVMES2
13521         XMIN(1,2)  = XMMIN
13522         XPOT1(3) = PSMES
13523         XMIN(1,3)  = XMMIN
13524 C  baryonic particle
13525       ELSE
13526         XPOT1(1) = PVBAR1
13527         XMIN(1,1)  = XBMIN
13528         XPOT1(2) = PVBAR2
13529         XMIN(1,2)  = XMMIN
13530         XPOT1(3) = PSBAR
13531         XMIN(1,3)  = XMMIN
13532       ENDIF
13533 C  particle 2
13534 C  mesonic particle
13535       XPOT2(1) = PVMES1
13536       XMIN(2,1)  = XMMIN
13537       XPOT2(2) = PVMES2
13538       XMIN(2,2)  = XMMIN
13539       XPOT2(3) = PSMES
13540       XMIN(2,3)  = XMMIN
13541 C
13542       XDUM1 = 0.01D0
13543       XDUM2 = 0.99D0
13544       CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13545      &            XSOFT1,XSOFT2,IREJ)
13546 C  rejection?
13547       IF(IREJ.NE.0) THEN
13548         IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13549      &    'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13550         IFAIL(15) = IFAIL(15)+1
13551         IREJ = 1
13552         RETURN
13553       ENDIF
13554 C  debug output
13555       IF(IDEB(74).GE.10) THEN
13556         WRITE(LO,'(1X,A,I6,2E12.4)')
13557      &    'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13558         DO 100 I=1,3
13559           WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13560  100    CONTINUE
13561       ENDIF
13562
13563       END
13564
13565 *$ CREATE PHO_SOFTXX.FOR
13566 *COPY PHO_SOFTXX
13567 CDECK  ID>, PHO_SOFTXX
13568       SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13569      &                  XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13570 C***********************************************************************
13571 C
13572 C    select soft x values
13573 C
13574 C    input:   JM1,JM2    mother particle index in POEVT1
13575 C                        (0  flavour not known before)
13576 C             MSPAR1,2   number of x values to select
13577 C             IVAL1,2    number valence quarks involved in hard
13578 C                        scattering (0,1,2)
13579 C             MSM1,2     minimum number of soft x to get sampled
13580 C             XSUM1,2    sum of all x values samples up this call
13581 C             XMAX1,2    max. x value
13582 C
13583 C    output   XSUM1,2    new sum of x-values sampled
13584 C             XS1,2      field containing sampled x values
13585 C
13586 C    x values of valence partons are first given
13587 C
13588 C***********************************************************************
13589       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13590       SAVE
13591
13592 C  input/output channels
13593       INTEGER LI,LO
13594       COMMON /POINOU/ LI,LO
13595 C  event debugging information
13596       INTEGER NMAXD
13597       PARAMETER (NMAXD=100)
13598       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13599      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13600       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13601      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13602 C  internal rejection counters
13603       INTEGER NMXJ
13604       PARAMETER (NMXJ=60)
13605       CHARACTER*10 REJTIT
13606       INTEGER IFAIL
13607       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13608 C  model switches and parameters
13609       CHARACTER*8 MDLNA
13610       INTEGER ISWMDL,IPAMDL
13611       DOUBLE PRECISION PARMDL
13612       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13613 C  data of c.m. system of Pomeron / Reggeon exchange
13614       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13615       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13616      &                 SIDP,CODP,SIFP,COFP
13617       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13618      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
13619      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
13620
13621 C  standard particle data interface
13622       INTEGER NMXHEP
13623
13624       PARAMETER (NMXHEP=4000)
13625
13626       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13627       DOUBLE PRECISION PHEP,VHEP
13628       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13629      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13630      &                VHEP(4,NMXHEP)
13631 C  extension to standard particle data interface (PHOJET specific)
13632       INTEGER IMPART,IPHIST,ICOLOR
13633       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13634
13635 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
13636       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13637       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13638       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13639      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13640 C  obsolete cut-off information
13641       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13642       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13643 C  data on most recent hard scattering
13644       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13645       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13646      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13647      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13648       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13649      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13650      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13651      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13652      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13653
13654       DIMENSION XS1(*),XS2(*)
13655
13656       INTEGER MAXPOT
13657       PARAMETER ( MAXPOT = 50 )
13658       DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13659
13660       IREJ = 0
13661
13662       MSMAX = MAX(MSPAR1,MSPAR2)
13663       MSMIN = MAX(MSM1,MSM2)
13664
13665       IF(MSMAX.GT.MAXPOT) THEN
13666         WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13667      &    'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13668         IREJ = 1
13669         RETURN
13670       ENDIF
13671
13672 C  determine exponents
13673       IBAR1 = ipho_bar3(JM1,2)
13674       IBAR2 = ipho_bar3(JM2,2)
13675       ISWAP = 0
13676       IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13677 C  meson-baryon scattering (asymmetric sea)
13678       IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13679         PSBAR = PARMDL(53)
13680         PSMES = PARMDL(57)
13681       ELSE
13682         PSBAR = PARMDL(52)
13683         PSMES = PARMDL(56)
13684       ENDIF
13685
13686 C  lower limits for x sampling
13687       XMMINA = 2.D0*PARMDL(157)/ECMP
13688       XBMINA = 2.D0*PARMDL(158)/ECMP
13689       XSMINA = 2.D0*PARMDL(159)/ECMP
13690       XMIN1 = MAX(XSOMIN,AS/XMAX2)
13691       XMIN2 = MAX(XSOMIN,AS/XMAX1)
13692       XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13693       XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13694       XMIN1 = MAX(AS/XMAX2,XMIN1)
13695       XMIN2 = MAX(AS/XMAX1,XMIN2)
13696
13697 C  particle 1
13698       XMMIN1 = MAX(XMIN1,XMMINA)
13699       XBMIN1 = MAX(XMIN1,XBMINA)
13700       XSMIN1 = MAX(XMIN1,XSMINA)
13701 C  mesonic particle
13702       IF(IBAR1.EQ.0) THEN
13703         IF(IHFLS(1).EQ.0) THEN
13704           XPOT1(1) = PARMDL(62)
13705           XMIN(1,1)  = XSMIN1
13706           XPOT1(2) = PARMDL(63)
13707           XMIN(1,2)  = XSMIN1
13708         ELSE
13709           XPOT1(1) = PARMDL(54)
13710           XMIN(1,1)  = XMMIN1
13711           XPOT1(2) = PARMDL(55)
13712           XMIN(1,2)  = XMMIN1
13713         ENDIF
13714         DO 100 I=3-IVAL1,MSMAX
13715           XPOT1(I) = PSMES
13716           XMIN(1,I)  = XSMIN1
13717  100    CONTINUE
13718 C  baryonic particle
13719       ELSE
13720         IF(IHFLS(1).EQ.0) THEN
13721           XPOT1(1) = PARMDL(62)
13722           XMIN(1,1)  = XSMIN1
13723           XPOT1(2) = PARMDL(63)
13724           XMIN(1,2)  = XSMIN1
13725         ELSE
13726           XPOT1(1) = PARMDL(50)
13727           XMIN(1,1)  = XBMIN1
13728           XPOT1(2) = PARMDL(51)
13729           XMIN(1,2)  = XMMIN1
13730         ENDIF
13731         DO 200 I=3-IVAL1,MSMAX
13732           XPOT1(I) = PSBAR
13733           XMIN(1,I)  = XSMIN1
13734  200    CONTINUE
13735       ENDIF
13736
13737 C  particle 2
13738       XMMIN2 = MAX(XMIN2,XMMINA)
13739       XBMIN2 = MAX(XMIN2,XBMINA)
13740       XSMIN2 = MAX(XMIN2,XSMINA)
13741 C  mesonic particle
13742       IF(IBAR2.EQ.0) THEN
13743         IF(IHFLS(2).EQ.0) THEN
13744           XPOT2(1) = PARMDL(62)
13745           XMIN(2,1)  = XSMIN2
13746           XPOT2(2) = PARMDL(63)
13747           XMIN(2,2)  = XSMIN2
13748         ELSE
13749           XPOT2(1) = PARMDL(54)
13750           XMIN(2,1)  = XMMIN2
13751           XPOT2(2) = PARMDL(55)
13752           XMIN(2,2)  = XMMIN2
13753         ENDIF
13754         DO 300 I=3-IVAL2,MSMAX
13755           XPOT2(I) = PSMES
13756           XMIN(2,I)  = XSMIN2
13757  300    CONTINUE
13758 C  baryonic particle
13759       ELSE
13760         IF(IHFLS(2).EQ.0) THEN
13761           XPOT2(1) = PARMDL(62)
13762           XMIN(2,1)  = XSMIN2
13763           XPOT2(2) = PARMDL(63)
13764           XMIN(2,2)  = XSMIN2
13765         ELSE
13766           XPOT2(1) = PARMDL(50)
13767           XMIN(2,1)  = XBMIN2
13768           XPOT2(2) = PARMDL(51)
13769           XMIN(2,2)  = XMMIN2
13770         ENDIF
13771         DO 400 I=3-IVAL2,MSMAX
13772           XPOT2(I) = PSBAR
13773           XMIN(2,I)  = XSMIN2
13774  400    CONTINUE
13775       ENDIF
13776
13777       XSS1 = XSUM1
13778       XSS2 = XSUM2
13779       MSOFT = MSMAX
13780
13781 C  check limits (important for valences)
13782       IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13783       IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13784
13785       XMINS1 = XSS1
13786       IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13787       XMINS2 = XSS2
13788       IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13789       DO 10 I=1,MSOFT
13790         XMINS1 = XMINS1+XMIN(1,I)
13791         XMINS2 = XMINS2+XMIN(2,I)
13792  10   CONTINUE
13793       IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13794
13795 C  try to sample x values
13796       IF(IPAMDL(14).EQ.0) THEN
13797         IF(MSOFT.EQ.2) THEN
13798           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13799      &                XS1,XS2,IREJ)
13800         ELSE IF(MSOFT.LT.5) THEN
13801           CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13802      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13803         ELSE
13804           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13805      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13806         ENDIF
13807       ELSE IF(IPAMDL(14).EQ.1) THEN
13808         IF(MSOFT.EQ.2) THEN
13809           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13810      &                XS1,XS2,IREJ)
13811         ELSE
13812           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13813      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13814         ENDIF
13815       ELSE IF(IPAMDL(14).EQ.2) THEN
13816         CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13817      &              XMAXP1,XMAXP2,XS1,XS2,IREJ)
13818       ELSE IF(IPAMDL(14).EQ.3) THEN
13819         IF(MSOFT.EQ.2) THEN
13820           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13821      &                XS1,XS2,IREJ)
13822         ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13823           CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13824      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13825         ELSE
13826           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13827      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13828         ENDIF
13829       ELSE
13830         WRITE(LO,'(/,1X,A,I3)')
13831      &    'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13832         STOP
13833       ENDIF
13834       IF(IREJ.NE.0) THEN
13835         IFAIL(41) = IFAIL(41)+1
13836         IF(IDEB(60).GE.2) THEN
13837           WRITE(LO,'(1X,A,I12,4I3)')
13838      &      'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13839      &      KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13840           WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13841      &      XSUM1,XSUM2,XMAX1,XMAX2
13842         ENDIF
13843         RETURN
13844       ENDIF
13845       IF(MSOFT.NE.MSMAX) THEN
13846         MSDIFF = MSMAX-MSOFT
13847         MSPAR1 = MSPAR1-MSDIFF
13848         MSPAR2 = MSPAR2-MSDIFF
13849       ENDIF
13850
13851 C  correct for different MSPAR numbers
13852       IF(MSOFT.NE.MSPAR1) THEN
13853         IF(MSPAR1.GT.1) THEN
13854           XDEL = 0.D0
13855           DO 500 I=MSPAR1+1,MSOFT
13856             XDEL = XDEL+XS1(I)
13857  500      CONTINUE
13858           XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13859           DO 550 I=2,MSPAR1
13860             XS1(I) = XS1(I)*XFAC
13861  550      CONTINUE
13862           XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13863         ELSE
13864           XSS1 = XSUM1
13865         ENDIF
13866       ENDIF
13867       IF(MSOFT.NE.MSPAR2) THEN
13868         IF(MSPAR2.GT.1) THEN
13869           XDEL = 0.D0
13870           DO 600 I=MSPAR2+1,MSOFT
13871             XDEL = XDEL+XS2(I)
13872  600      CONTINUE
13873           XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13874           DO 650 I=2,MSPAR2
13875             XS2(I) = XS2(I)*XFAC
13876  650      CONTINUE
13877           XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13878         ELSE
13879           XSS2 = XSUM2
13880         ENDIF
13881       ENDIF
13882
13883 C  first x entry
13884       XS1(1) = 1.D0 - XSS1
13885       XS2(1) = 1.D0 - XSS2
13886       XSUM1 = XSS1
13887       XSUM2 = XSS2
13888
13889 C  debug output
13890       IF(IDEB(60).GE.10) THEN
13891         WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13892      &    'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13893      &    KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13894         WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I  XS1/2   XPOT1/2  XMIN1/2'
13895         DO 30 I=1,MSOFT
13896           WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13897      &      XMIN(1,I),XMIN(2,I)
13898  30     CONTINUE
13899       ENDIF
13900
13901       RETURN
13902
13903 C  not enough phase space
13904  1000 CONTINUE
13905
13906       IFAIL(42) = IFAIL(42)+1
13907       IREJ = 1
13908
13909 C  warning message
13910       IF(IDEB(60).GE.1) THEN
13911         WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13912      &    'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13913      &    ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13914      &    XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13915         WRITE(LO,'(1X,A,1P,3E11.3)')
13916      &    'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13917         WRITE(LO,'(1X,A,1P,3E11.3)')
13918      &    'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13919         WRITE(LO,'(1X,A,1P,3E11.3)')
13920      &    'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13921         WRITE(LO,'(1X,A)')
13922      &    'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13923         DO 27 I=1,MSOFT
13924           WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13925  27     CONTINUE
13926         WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13927      &    'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13928      &    KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13929         WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I   XPOT1/2   XMIN1/2'
13930         DO 25 I=1,MSOFT
13931           WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13932      &    XMIN(1,I),XMIN(2,I)
13933  25     CONTINUE
13934       ENDIF
13935
13936       END
13937
13938 *$ CREATE PHO_SELSXR.FOR
13939 *COPY PHO_SELSXR
13940 CDECK  ID>, PHO_SELSXR
13941       SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13942      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13943 C***********************************************************************
13944 C
13945 C    select x values of soft string ends (rejection method)
13946 C
13947 C***********************************************************************
13948       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13949       SAVE
13950
13951       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13952
13953 C  input/output channels
13954       INTEGER LI,LO
13955       COMMON /POINOU/ LI,LO
13956 C  event debugging information
13957       INTEGER NMAXD
13958       PARAMETER (NMAXD=100)
13959       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13960      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13961       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13962      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13963 C  model switches and parameters
13964       CHARACTER*8 MDLNA
13965       INTEGER ISWMDL,IPAMDL
13966       DOUBLE PRECISION PARMDL
13967       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13968 C  data on most recent hard scattering
13969       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13970       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13971      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13972      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13973       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13974      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13975      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13976      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13977      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13978 C  global event kinematics and particle IDs
13979       INTEGER IFPAP,IFPAB
13980       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13981       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13982 C  obsolete cut-off information
13983       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13984       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13985
13986       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13987
13988       IF(IDEB(13).GE.10) THEN
13989         WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13990         WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13991      &    MSOFT,XS1,XS2,XMAX1,XMAX2
13992         DO 40 I=1,MSOFT
13993           WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13994  40     CONTINUE
13995       ENDIF
13996 C
13997       IREJ = 0
13998 C
13999       XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
14000       XMIN1 = MAX(AS/XMAX1,XMINK)
14001       XMIN2 = MAX(AS/XMAX2,XMINK)
14002 C
14003       IF(MSOFT.EQ.1) THEN
14004         XSOFT1(2) = 0.D0
14005         XSOFT2(2) = 0.D0
14006         RETURN
14007       ENDIF
14008       XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
14009      &        *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
14010 C
14011  10   CONTINUE
14012 C
14013       DO 50 I=2,MSOFT
14014         POT(1,I) = XPOT1(I)+1.D0
14015         POT(2,I) = XPOT2(I)+1.D0
14016         REVP(1,I) = 1.D0/POT(1,I)
14017         REVP(2,I) = 1.D0/POT(2,I)
14018         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14019         XLMAX = XMAX1**POT(1,I)
14020         XLDIF(1,I) = XLMAX-XLMIN(1,I)
14021         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14022         XLMAX = XMAX2**POT(2,I)
14023         XLDIF(2,I) = XLMAX-XLMIN(2,I)
14024  50   CONTINUE
14025 C
14026       ITRY0 = 0
14027  5    CONTINUE
14028       ITRY0 = ITRY0 + 1
14029       IF(ITRY0.GE.IPAMDL(181)) THEN
14030         IF(MSOFT-MSMIN.GE.2) THEN
14031           MSOFT = MSMIN
14032           GOTO 10
14033         ENDIF
14034         GOTO 1000
14035       ENDIF
14036       XREST1 = 1.D0-XS1
14037       XREST2 = 1.D0-XS2
14038       DO 100 I=2,MSOFT
14039         ITRY1 = 0
14040
14041  20     CONTINUE
14042         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14043         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14044         XSOFT1(I) = Z1**REVP(1,I)
14045         XSOFT2(I) = Z2**REVP(2,I)
14046         ITRY1 = ITRY1+1
14047         IF(ITRY1.GE.50) GOTO 1000
14048         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14049
14050         XREST1 = XREST1-XSOFT1(I)
14051         IF(XREST1.LT.XMIN1) GOTO 5
14052         IF(XREST1.LT.XMIN(1,1)) GOTO 5
14053         XREST2 = XREST2-XSOFT2(I)
14054         IF(XREST2.LT.XMIN2) GOTO 5
14055         IF(XREST2.LT.XMIN(2,1)) GOTO 5
14056         IF(XREST1*XREST2.LT.AS) GOTO 5
14057
14058  100  CONTINUE
14059       XSOFT1(1) = XREST1
14060       XSOFT2(1) = XREST2
14061       IREJ=0
14062 *     XX = 1.D0
14063 *     DO 200 I=2,MSOFT
14064 *       XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
14065 *200  CONTINUE
14066       XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
14067       IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
14068
14069       XS1 = 1.D0-XREST1
14070       XS2 = 1.D0-XREST2
14071       RETURN
14072
14073  1000 CONTINUE
14074       IREJ = 1
14075       IF(IDEB(13).GE.2) THEN
14076         WRITE(LO,'(1X,A,2I4)')
14077      &    'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
14078         WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14079       ENDIF
14080
14081       END
14082
14083 *$ CREATE PHO_SELSX2.FOR
14084 *COPY PHO_SELSX2
14085 CDECK  ID>, PHO_SELSX2
14086       SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14087      &                  XS1,XS2,IREJ)
14088 C***********************************************************************
14089 C
14090 C    select x values of soft string ends using PHO_RNDBET
14091 C
14092 C***********************************************************************
14093       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14094       SAVE
14095
14096       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
14097
14098 C  input/output channels
14099       INTEGER LI,LO
14100       COMMON /POINOU/ LI,LO
14101 C  event debugging information
14102       INTEGER NMAXD
14103       PARAMETER (NMAXD=100)
14104       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14105      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14106       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14107      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14108 C  model switches and parameters
14109       CHARACTER*8 MDLNA
14110       INTEGER ISWMDL,IPAMDL
14111       DOUBLE PRECISION PARMDL
14112       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14113 C  data on most recent hard scattering
14114       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14115       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14116      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14117      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14118       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14119      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14120      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14121      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14122      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14123 C  obsolete cut-off information
14124       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14125       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14126
14127       IREJ = 0
14128
14129       IF(IDEB(32).GE.10) THEN
14130         WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14131         WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14132      &    AS,XSUM1,XSUM2,XMAX1,XMAX2
14133         DO 30 I=1,2
14134           WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14135  30     CONTINUE
14136       ENDIF
14137
14138       FAC1 = 1.D0-XSUM1
14139       FAC2 = 1.D0-XSUM2
14140       FAC = FAC1*FAC2
14141       GAM1 = XPOT1(1)+1.D0
14142       GAM2 = XPOT2(1)+1.D0
14143       BET1 = XPOT1(2)+1.D0
14144       BET2 = XPOT2(2)+1.D0
14145
14146       ITRY0 = 0
14147       DO 100 I=1,IPAMDL(182)
14148
14149         ITRY1 = 0
14150  10     CONTINUE
14151           X1 = PHO_RNDBET(GAM1,BET1)
14152           ITRY1 = ITRY1+1
14153           IF(ITRY1.GE.50) GOTO 1000
14154         IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14155
14156         ITRY2 = 0
14157  11     CONTINUE
14158           X2 = PHO_RNDBET(GAM2,BET2)
14159           ITRY2 = ITRY2+1
14160           IF(ITRY2.GE.50) GOTO 1000
14161         IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14162
14163         X3 = 1.D0 - X1
14164         X4 = 1.D0 - X2
14165         IF(X1*X2*FAC.GT.AS) THEN
14166           IF(X3*X4*FAC.GT.AS) THEN
14167             XS1(1) = X1*FAC1
14168             XS1(2) = X3*FAC1
14169             XS2(1) = X2*FAC2
14170             XS2(2) = X4*FAC2
14171             IF(XS1(1).GT.XMIN(1,1)) THEN
14172               IF(XS2(1).GT.XMIN(2,1)) THEN
14173                 IF(XS1(2).GT.XMIN(1,2)) THEN
14174                   IF(XS2(2).GT.XMIN(2,2)) THEN
14175                     XSUM1 = XSUM1+XS1(2)
14176                     XSUM2 = XSUM2+XS2(2)
14177                     GOTO 300
14178                   ENDIF
14179                 ENDIF
14180               ENDIF
14181             ENDIF
14182           ENDIF
14183         ENDIF
14184         ITRY0 = ITRY0+1
14185
14186  100  CONTINUE
14187
14188  1000 CONTINUE
14189       IREJ = 1
14190       IF(IDEB(32).GE.2) THEN
14191         WRITE(LO,'(1X,A,3I4)')
14192      &    'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14193         WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14194       ENDIF
14195       RETURN
14196  300  CONTINUE
14197
14198       END
14199
14200 *$ CREATE PHO_SELSXS.FOR
14201 *COPY PHO_SELSXS
14202 CDECK  ID>, PHO_SELSXS
14203       SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14204      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14205 C***********************************************************************
14206 C
14207 C    select x values of soft string ends (rescaling method)
14208 C
14209 C***********************************************************************
14210       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14211       SAVE
14212
14213       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14214
14215 C  input/output channels
14216       INTEGER LI,LO
14217       COMMON /POINOU/ LI,LO
14218 C  event debugging information
14219       INTEGER NMAXD
14220       PARAMETER (NMAXD=100)
14221       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14222      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14223       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14224      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14225 C  model switches and parameters
14226       CHARACTER*8 MDLNA
14227       INTEGER ISWMDL,IPAMDL
14228       DOUBLE PRECISION PARMDL
14229       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14230 C  data on most recent hard scattering
14231       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14232       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14233      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14234      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14235       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14236      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14237      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14238      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14239      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14240 C  obsolete cut-off information
14241       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14242       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14243
14244       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14245
14246       IREJ = 0
14247
14248  10   CONTINUE
14249
14250       IF(MSOFT.EQ.1) THEN
14251         XSOFT1(1) = 1.D0-XS1
14252         XSOFT1(2) = 0.D0
14253         XSOFT2(1) = 1.D0-XS2
14254         XSOFT2(2) = 0.D0
14255         RETURN
14256       ENDIF
14257
14258       DO 50 I=1,MSOFT
14259         POT(1,I) = XPOT1(I)+1.D0
14260         POT(2,I) = XPOT2(I)+1.D0
14261         REVP(1,I) = 1.D0/POT(1,I)
14262         REVP(2,I) = 1.D0/POT(2,I)
14263         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14264         XLMAX = XMAX1**POT(1,I)
14265         XLDIF(1,I) = XLMAX-XLMIN(1,I)
14266         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14267         XLMAX = XMAX2**POT(2,I)
14268         XLDIF(2,I) = XLMAX-XLMIN(2,I)
14269  50   CONTINUE
14270
14271       ITRY0 = 0
14272  5    CONTINUE
14273       ITRY0 = ITRY0 + 1
14274       IF(ITRY0.GE.IPAMDL(180)) THEN
14275         IF(MSOFT-MSMIN.GE.2) THEN
14276           MSOFT= MSMIN
14277           GOTO 10
14278         ENDIF
14279         GOTO 1000
14280       ENDIF
14281       XSUM1 = 0.D0
14282       XSUM2 = 0.D0
14283       DO 100 I=1,MSOFT
14284         ITRY1 = 0
14285  20     CONTINUE
14286         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14287         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14288         XSOFT1(I) = Z1**REVP(1,I)
14289         XSOFT2(I) = Z2**REVP(2,I)
14290         ITRY1 = ITRY1+1
14291         IF(ITRY1.GE.50) GOTO 1000
14292         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14293         XSUM1 = XSUM1+XSOFT1(I)
14294         XSUM2 = XSUM2+XSOFT2(I)
14295  100  CONTINUE
14296       FAC1 = (1.D0-XS1)/XSUM1
14297       FAC2 = (1.D0-XS2)/XSUM2
14298       DO 200 I=1,MSOFT
14299         XSOFT1(I) = XSOFT1(I)*FAC1
14300         XSOFT2(I) = XSOFT2(I)*FAC2
14301         IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14302         IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14303         IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14304  200  CONTINUE
14305
14306       XS1 = 1.D0-XSOFT1(1)
14307       XS2 = 1.D0-XSOFT2(1)
14308       RETURN
14309
14310  1000 CONTINUE
14311       IREJ = 1
14312       IF(IDEB(14).GE.2) THEN
14313         WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14314      &    'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14315         DO 300 I=1,MSOFT
14316           WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14317  300    CONTINUE
14318       ENDIF
14319
14320       END
14321
14322 *$ CREATE PHO_SELSXI.FOR
14323 *COPY PHO_SELSXI
14324 CDECK  ID>, PHO_SELSXI
14325       SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14326      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14327 C***********************************************************************
14328 C
14329 C    select x values of soft string ends (sea independent from valence)
14330 C
14331 C***********************************************************************
14332       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14333       SAVE
14334
14335       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14336
14337 C  input/output channels
14338       INTEGER LI,LO
14339       COMMON /POINOU/ LI,LO
14340 C  event debugging information
14341       INTEGER NMAXD
14342       PARAMETER (NMAXD=100)
14343       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14344      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14345       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14346      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14347 C  model switches and parameters
14348       CHARACTER*8 MDLNA
14349       INTEGER ISWMDL,IPAMDL
14350       DOUBLE PRECISION PARMDL
14351       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14352 C  data on most recent hard scattering
14353       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14354       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14355      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14356      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14357       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14358      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14359      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14360      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14361      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14362 C  obsolete cut-off information
14363       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14364       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14365
14366       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14367
14368       IREJ = 0
14369
14370  10   CONTINUE
14371
14372       DO 50 I=1,MSOFT
14373         POT(1,I) = XPOT1(I)+1.D0
14374         POT(2,I) = XPOT2(I)+1.D0
14375         REVP(1,I) = 1.D0/POT(1,I)
14376         REVP(2,I) = 1.D0/POT(2,I)
14377         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14378         XLMAX = XMAX1**POT(1,I)
14379         XLDIF(1,I) = XLMAX-XLMIN(1,I)
14380         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14381         XLMAX = XMAX2**POT(2,I)
14382         XLDIF(2,I) = XLMAX-XLMIN(2,I)
14383  50   CONTINUE
14384
14385 C  selection of sea
14386       ITRY0 = 0
14387  5    CONTINUE
14388
14389       ITRY0 = ITRY0 + 1
14390       IF(ITRY0.GE.IPAMDL(183)) THEN
14391         IF(MSOFT-MSMIN.GE.2) THEN
14392           MSOFT = MSMIN
14393           GOTO 10
14394         ENDIF
14395         GOTO 1000
14396       ENDIF
14397       XSUM1 = XS1
14398       XSUM2 = XS2
14399       DO 100 I=3,MSOFT
14400         ITRY1 = 0
14401  20     CONTINUE
14402         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14403         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14404         XSOFT1(I) = Z1**REVP(1,I)
14405         XSOFT2(I) = Z2**REVP(2,I)
14406         ITRY1 = ITRY1+1
14407         IF(ITRY1.GE.50) GOTO 1000
14408         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14409         XSUM1 = XSUM1+XSOFT1(I)
14410         XSUM2 = XSUM2+XSOFT2(I)
14411  100  CONTINUE
14412
14413       IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14414       IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14415
14416 C  selection of valence
14417       CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14418      &  XSOFT1,XSOFT2,IREJ)
14419       IF(IREJ.NE.0) THEN
14420         IF(MSOFT-MSMIN.GE.2) THEN
14421           MSOFT = MSMIN
14422           GOTO 10
14423         ENDIF
14424         IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14425      &    'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14426      &    XSUM1,XSUM2,XMAX1,XMAX2
14427         RETURN
14428       ENDIF
14429
14430       XS1 = 1.D0-XSOFT1(1)
14431       XS2 = 1.D0-XSOFT2(1)
14432       RETURN
14433
14434  1000 CONTINUE
14435       IREJ = 1
14436       IF(IDEB(14).GE.2) THEN
14437         WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14438      &    'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14439         DO 300 I=1,MSOFT
14440           WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14441  300    CONTINUE
14442       ENDIF
14443
14444       END
14445
14446 *$ CREATE PHO_SELCOL.FOR
14447 *COPY PHO_SELCOL
14448 CDECK  ID>, PHO_SELCOL
14449       SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14450 C********************************************************************
14451 C
14452 C    color combinatorics
14453 C
14454 C    input:         ICO1,2   colors of incoming particle
14455 C                   IMODE    -2  output of initialization status
14456 C                            -1  initialization
14457 C                                   ICINP(1) selection mode
14458 C                                            0   QCD
14459 C                                            1   large N_c expansion
14460 C                                   ICINP(2) max. allowed color
14461 C                            0   clear internal color counter
14462 C                            1   hadron into two colored objects
14463 C                            2   quark into quark gluon
14464 C                            3   gluon into gluon gluon
14465 C                            4   gluon into quark antiquark
14466 C
14467 C    output:        ICOA1,2  colors of first outgoing particle
14468 C                   ICOB1,2  colors of second outgoing particle
14469 C
14470 C********************************************************************
14471       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14472       SAVE
14473
14474 C  input/output channels
14475       INTEGER LI,LO
14476       COMMON /POINOU/ LI,LO
14477 C  event debugging information
14478       INTEGER NMAXD
14479       PARAMETER (NMAXD=100)
14480       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14481      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14482       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14483      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14484
14485       DATA METHOD /0/, II /0/
14486
14487       ICI1 = ICO1
14488       ICI2 = ICO2
14489       IF(METHOD.EQ.0) THEN
14490
14491         IF(IMODE.EQ.1) THEN
14492           II = II+1
14493           IF(II.GT.MAXCOL)
14494      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14495           ICOA1 = II
14496           ICOA2 = 0
14497           ICOB1 = -II
14498           ICOB2 = 0
14499         ELSE IF(IMODE.EQ.2) THEN
14500           II = II+1
14501           IF(II.GT.MAXCOL)
14502      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14503           ICOA2 = 0
14504           IF(ICI1.GT.0) THEN
14505             ICOA1 = II
14506             ICOB1 = ICI1
14507             ICOB2 = -II
14508           ELSE
14509             ICOA1 = -II
14510             ICOB1 = II
14511             ICOB2 = ICI1
14512           ENDIF
14513         ELSE IF(IMODE.EQ.3) THEN
14514           II = II+1
14515           IF(II.GT.MAXCOL)
14516      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14517           IF(DT_RNDM(DUM).GT.0.5D0) THEN
14518             ICOA1 = ICI1
14519             ICOA2 = -II
14520             ICOB1 = II
14521             ICOB2 = ICI2
14522           ELSE
14523             ICOB1 = ICI1
14524             ICOB2 = -II
14525             ICOA1 = II
14526             ICOA2 = ICI2
14527           ENDIF
14528         ELSE IF(IMODE.EQ.4) THEN
14529           ICOA1 = ICI1
14530           ICOA2 = 0
14531           ICOB1 = ICI2
14532           ICOB2 = 0
14533         ELSE IF(IMODE.EQ.0) THEN
14534           II = 0
14535         ELSE IF(IMODE.EQ.-1) THEN
14536           METHOD = ICI1
14537           MAXCOL = ICI2
14538         ELSE IF(IMODE.EQ.-2) THEN
14539           WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14540      &      METHOD,MAXCOL
14541         ELSE
14542           WRITE(LO,'(1X,A,I5)')
14543      &      'PHO_SELCOL:ERROR: unsupported mode',IMODE
14544           CALL PHO_ABORT
14545         ENDIF
14546
14547       ELSE
14548         WRITE(LO,'(1X,A,I5)')
14549      &    'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14550         CALL PHO_ABORT
14551       ENDIF
14552
14553       II = ABS(II)
14554       IF(IDEB(75).GE.10) THEN
14555         WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14556      &    IMODE,MAXCOL,II
14557         WRITE(LO,'(10X,A,2I5)') 'input  colors',ICI1,ICI2
14558         WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14559       ENDIF
14560
14561       END
14562
14563 *$ CREATE ipho_diqu.FOR
14564 *COPY ipho_diqu
14565 CDECK  ID>, ipho_diqu
14566       INTEGER FUNCTION ipho_diqu(iq1,iq2)
14567 C***********************************************************************
14568 C
14569 C     selection of diquark number (PDG convention)
14570 C
14571 C***********************************************************************
14572
14573       IMPLICIT NONE
14574
14575       SAVE
14576
14577       integer iq1,iq2
14578
14579 C  input/output channels
14580       INTEGER LI,LO
14581       COMMON /POINOU/ LI,LO
14582 C  event debugging information
14583       INTEGER NMAXD
14584       PARAMETER (NMAXD=100)
14585       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14586      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14587       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14588      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14589 C  model switches and parameters
14590       CHARACTER*8 MDLNA
14591       INTEGER ISWMDL,IPAMDL
14592       DOUBLE PRECISION PARMDL
14593       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14594
14595 C  external functions
14596       double precision DT_RNDM
14597
14598 C  local variables
14599       integer i0,i1,i2
14600       double precision dum
14601
14602       i1 = abs(iq1)
14603       i2 = abs(iq2)
14604
14605       if(i1.eq.i2) then
14606         i0 = i1*1100+3
14607       else
14608         i0 = max(i1,i2)*1000+min(i1,i2)*100
14609         if(DT_RNDM(dum).gt.PARMDL(135)) then
14610           i0 = i0+1
14611         else
14612           i0 = i0+3
14613         endif
14614       endif
14615
14616       ipho_diqu = sign(i0,iq1)
14617
14618       END
14619
14620 *$ CREATE PHO_PARREM.FOR
14621 *COPY PHO_PARREM
14622 CDECK  ID>, PHO_PARREM
14623       SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14624 C**********************************************************************
14625 C
14626 C     selection of particle remnant flavour(s) (quark or diquark)
14627 C
14628 C     input:    INDX   index of particle in /POEVT1/
14629 C               IOUT   parton which was taken out
14630 C
14631 C     output:   IREM   remnant according to valence flavours
14632 C               IREJ   0  flavour combination possible
14633 C                      1  flavour combination impossible
14634 C
14635 C     all particle ID are given according to PDG conventions
14636 C
14637 C**********************************************************************
14638
14639       IMPLICIT NONE
14640
14641       SAVE
14642
14643       integer INDX,IOUT,IREM,IREJ
14644
14645 C  input/output channels
14646       INTEGER LI,LO
14647       COMMON /POINOU/ LI,LO
14648 C  event debugging information
14649       INTEGER NMAXD
14650       PARAMETER (NMAXD=100)
14651       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14652      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14653       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14654      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14655
14656 C  standard particle data interface
14657       INTEGER NMXHEP
14658
14659       PARAMETER (NMXHEP=4000)
14660
14661       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14662       DOUBLE PRECISION PHEP,VHEP
14663       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14664      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14665      &                VHEP(4,NMXHEP)
14666 C  extension to standard particle data interface (PHOJET specific)
14667       INTEGER IMPART,IPHIST,ICOLOR
14668       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14669
14670 C  general particle data
14671       double precision xm_list,tau_list,gam_list,
14672      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14673      &  xm_bb82_list,xm_bb102_list
14674       integer          ich3_list,iba3_list,iq_list,
14675      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
14676       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14677      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
14678      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14679      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14680      &  ich3_list(300),iba3_list(300),iq_list(3,300),
14681      &  id_psm_list(6,6),id_vem_list(6,6),
14682      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
14683
14684 C  external functions
14685       integer ipho_diqu
14686
14687 C  local variables
14688       integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14689       dimension IQUA(3),IDQ(2)
14690
14691       ID1 = IDHEP(INDX)
14692       ID2 = IMPART(INDX)
14693       IREJ = 0
14694
14695       IF(ID2.EQ.0) THEN
14696         WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14697         CALL PHO_ABORT
14698       ENDIF
14699
14700 C  particle with flavour mixing
14701       if(ID1.eq.22) then
14702 C  photon
14703         IREM = -IOUT
14704         GOTO 100
14705       else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14706 C  pi0, rho0, and omega
14707         IF(ABS(IOUT).LE.2) THEN
14708           IREM = -IOUT
14709           GOTO 100
14710         ELSE
14711           GOTO 150
14712         ENDIF
14713       else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14714 C  neutral kaons (K0,K0-bar)
14715         if(abs(IOUT).eq.1) then
14716           IREM = sign(3,-IOUT)
14717           goto 100
14718         else if(abs(IOUT).eq.3) then
14719           IREM = sign(1,-IOUT)
14720           goto 100
14721         else
14722           goto 150
14723         endif
14724       else if((ID1.eq.990).or.(ID1.eq.110)) then
14725 C  pomeron and reggeon
14726         IREM = -IOUT
14727         GOTO 100
14728       endif
14729
14730 C  ordinary hadron
14731       ID = abs(ID2)
14732       IS = sign(1,ID2)
14733       IQUA(1) = iq_list(1,ID)*IS
14734       IQUA(2) = iq_list(2,ID)*IS
14735       IQUA(3) = iq_list(3,ID)*IS
14736
14737 C  compare to flavour content
14738       IF(ABS(IOUT).LT.1000) THEN
14739 C  single quark requested
14740         IF(IQUA(1).EQ.IOUT) THEN
14741           K1 = 2
14742           K2 = 3
14743         ELSE IF(IQUA(2).EQ.IOUT) THEN
14744           K1 = 1
14745           K2 = 3
14746         ELSE IF(IQUA(3).EQ.IOUT) THEN
14747           K1 = 1
14748           K2 = 2
14749         ELSE
14750           GOTO 150
14751         ENDIF
14752         IF(IQUA(3).EQ.0) THEN
14753           IREM = IQUA(K1)
14754         ELSE
14755           IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14756         ENDIF
14757       ELSE IF(IQUA(3).NE.0) THEN
14758 C  diquark requested from baryon
14759         IDQ(1) = IOUT/1000
14760         IDQ(2) = (IOUT-IDQ(1)*1000)/100
14761         do i=1,2
14762           do k=1,3
14763             if(IDQ(i).eq.IQUA(k)) then
14764               IQUA(k) = 0
14765               goto 110
14766             endif
14767           enddo
14768           goto 150
14769  110      continue
14770         enddo
14771         IREM = IQUA(1)+IQUA(2)+IQUA(3)
14772       ENDIF
14773
14774  100  CONTINUE
14775 C  debug output
14776       IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14777      &  'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14778      &  INDX,ID1,ID2,IOUT,IREM
14779       RETURN
14780
14781 C  rejection
14782  150  CONTINUE
14783       IREJ = 1
14784       IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14785      &  'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14786
14787       END
14788
14789 *$ CREATE PHO_VALFLA.FOR
14790 *COPY PHO_VALFLA
14791 CDECK  ID>, PHO_VALFLA
14792       SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14793 C***********************************************************************
14794 C
14795 C     selection of valence flavour decomposition of particle IPAR
14796 C
14797 C     input:    IPAR   particle index in /POEVT1/
14798 C                      -1   initialization
14799 C                      -2   output of statistics
14800 C               XMASS  mass of particle
14801 C                      (important for pomeron:
14802 C                       mass dependent flavour sampling)
14803 C
14804 C     output:   IFL1,IFL2
14805 C               baryon: IFL1  diquark flavour
14806 C               (valence flavours according to PDG conventions)
14807 C
14808 C***********************************************************************
14809       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14810       SAVE
14811
14812       PARAMETER ( EPS    =  0.1D0,
14813      &            DEPS   =  1.D-15)
14814
14815 C  input/output channels
14816       INTEGER LI,LO
14817       COMMON /POINOU/ LI,LO
14818 C  event debugging information
14819       INTEGER NMAXD
14820       PARAMETER (NMAXD=100)
14821       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14822      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14823       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14824      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14825 C  model switches and parameters
14826       CHARACTER*8 MDLNA
14827       INTEGER ISWMDL,IPAMDL
14828       DOUBLE PRECISION PARMDL
14829       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14830
14831 C  standard particle data interface
14832       INTEGER NMXHEP
14833
14834       PARAMETER (NMXHEP=4000)
14835
14836       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14837       DOUBLE PRECISION PHEP,VHEP
14838       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14839      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14840      &                VHEP(4,NMXHEP)
14841 C  extension to standard particle data interface (PHOJET specific)
14842       INTEGER IMPART,IPHIST,ICOLOR
14843       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14844
14845 C  general particle data
14846       double precision xm_list,tau_list,gam_list,
14847      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14848      &  xm_bb82_list,xm_bb102_list
14849       integer          ich3_list,iba3_list,iq_list,
14850      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
14851       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14852      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
14853      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14854      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14855      &  ich3_list(300),iba3_list(300),iq_list(3,300),
14856      &  id_psm_list(6,6),id_vem_list(6,6),
14857      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
14858
14859       data ITMX / 5 /
14860
14861       IF(IPAR.GT.0) THEN
14862         K = IPAR
14863 C  select particle code
14864         ID1 = IDHEP(K)
14865         ID  = abs(IMPART(K))
14866         IBAR = IPHO_BAR3(K,2)
14867         ITER = 0
14868
14869  10     CONTINUE
14870
14871         ifl1 = 0
14872         ifl2 = 0
14873         ITER = ITER+1
14874         if(ITER.GT.ITMX) then
14875           WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14876      &      'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14877           return
14878         endif
14879
14880 C  not baryon
14881         IF(IBAR.EQ.0) THEN
14882
14883 C  photon
14884           IF(ID1.EQ.22) THEN
14885 C  charge dependent flavour sampling
14886  15         CONTINUE
14887             K = INT(DT_RNDM(E1)*6.D0)+1
14888             IF(K.LE.4) THEN
14889               IFL1 = 2
14890               IFL2 = -2
14891             ELSE IF(K.EQ.5) THEN
14892               IFL1 = 1
14893               IFL2 = -1
14894             ELSE
14895               IFL1 = 3
14896               IFL2 = -3
14897             ENDIF
14898 C  optional strangeness suppression
14899             IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14900             IF(DT_RNDM(DUM).LT.0.5D0) THEN
14901               K = IFL1
14902               IFL1 = IFL2
14903               IFL2 = K
14904             ENDIF
14905
14906 C  pomeron, reggeon
14907           ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14908             IF(ISWMDL(19).EQ.0) THEN
14909 C  SU(3) symmetric valences
14910               K = INT(DT_RNDM(E1)*3.D0)+1
14911               IF(DT_RNDM(DUM).LT.0.5D0) THEN
14912                 IFL1 = K
14913               ELSE
14914                 IFL1 = -K
14915               ENDIF
14916               IFL2 = -IFL1
14917             ELSE IF(ISWMDL(19).EQ.1) THEN
14918 C  mass dependent flavour sampling
14919               EMIN = MIN(E1,E2)
14920               CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14921             ELSE
14922               WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14923      &          'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14924               CALL PHO_ABORT
14925             ENDIF
14926
14927 C  meson with flavour mixing
14928           ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14929             K = INT(2.D0*DT_RNDM(E1))+1
14930             IFL1 = K
14931             IFL2 = -K
14932 C  meson (standard)
14933           ELSE
14934             K = INT(2.D0*DT_RNDM(E1))+1
14935             IFL1 = iq_list(K,ID)
14936             K = MOD(K,2) + 1
14937             IFL2 = iq_list(K,ID)
14938             if(IFL1.EQ.0) then
14939               EMIN = MIN(E1,E2)
14940               CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14941             endif
14942           ENDIF
14943
14944 C  baryon
14945         ELSE
14946           K = INT(2.999999D0*DT_RNDM(E2))+1
14947           K1 = MOD(K,3)+1
14948           K2 = MOD(K1,3)+1
14949           IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14950           IFL2 = iq_list(K,ID)
14951         ENDIF
14952
14953 C  change sign for antiparticles
14954         if(ID1.lt.0) then
14955           IFL1 = -IFL1
14956           IFL2 = -IFL2
14957         endif
14958
14959 ************************************************************************
14960 C  check kinematic constraints
14961 *       IF((PHO_PMASS(IFL1,3).GT.E1)
14962 *    &     .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14963 ************************************************************************
14964
14965 C  debug output
14966         IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14967      &    'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14968
14969       ELSE IF(IPAR.EQ.-1) THEN
14970 C  initialization
14971
14972       ELSE IF(IPAR.EQ.-2) THEN
14973 C  output of final statistics
14974
14975       ELSE
14976         WRITE(LO,'(1X,A,I10)')
14977      &    'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14978         CALL PHO_ABORT
14979       ENDIF
14980
14981       END
14982
14983 *$ CREATE PHO_REGFLA.FOR
14984 *COPY PHO_REGFLA
14985 CDECK  ID>, PHO_REGFLA
14986       SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14987 C**********************************************************************
14988 C
14989 C     selection of reggeon flavours
14990 C
14991 C     input:    JM1,JM2      position index of mother hadrons
14992 C
14993 C     output:   IFLR1,IFLR2  valence flavours according to
14994 C                            PDG conventions and JM1,JM2
14995 C               IREJ         0  reggeon possible
14996 C                            1  reggeon impossible
14997 C
14998 C**********************************************************************
14999       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15000       SAVE
15001
15002       PARAMETER ( EPS    =  0.1D0,
15003      &            DEPS   =  1.D-15)
15004
15005 C  input/output channels
15006       INTEGER LI,LO
15007       COMMON /POINOU/ LI,LO
15008 C  event debugging information
15009       INTEGER NMAXD
15010       PARAMETER (NMAXD=100)
15011       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15012      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15013       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15014      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15015 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
15016       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
15017       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
15018       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
15019      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
15020
15021 C  standard particle data interface
15022       INTEGER NMXHEP
15023
15024       PARAMETER (NMXHEP=4000)
15025
15026       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15027       DOUBLE PRECISION PHEP,VHEP
15028       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15029      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15030      &                VHEP(4,NMXHEP)
15031 C  extension to standard particle data interface (PHOJET specific)
15032       INTEGER IMPART,IPHIST,ICOLOR
15033       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15034
15035       IF(JM1.GT.0) THEN
15036         IREJ = 0
15037         ITER = 0
15038 C  available energy
15039         E1   = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
15040      &             -(PHEP(1,JM1)+PHEP(1,JM2))**2
15041      &             -(PHEP(2,JM1)+PHEP(2,JM2))**2
15042      &             -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
15043  50     CONTINUE
15044         ITER = ITER+1
15045         IF(ITER.GT.50) THEN
15046           IREJ = 1
15047 C  debug output
15048           IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
15049      &      'PHO_REGFLA: rejection, no reggeon found for',
15050      &      IDHEP(JM1),IDHEP(JM2),E1
15051           RETURN
15052         ENDIF
15053
15054         CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
15055         CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
15056         IF(IFLA1.EQ.-IFLB1) THEN
15057           IFLR1 = IFLA2
15058           IFLR2 = IFLB2
15059         ELSE IF(IFLA1.EQ.-IFLB2) THEN
15060           IFLR1 = IFLA2
15061           IFLR2 = IFLB1
15062         ELSE IF(IFLA2.EQ.-IFLB1) THEN
15063           IFLR1 = IFLA1
15064           IFLR2 = IFLB2
15065         ELSE IF(IFLA2.EQ.-IFLB2) THEN
15066           IFLR1 = IFLA1
15067           IFLR2 = IFLB1
15068         ELSE
15069 C  debug output
15070           IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
15071      &      'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
15072           GOTO 50
15073         ENDIF
15074 C  debug output
15075         IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
15076      &    'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
15077      &    JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
15078       ELSE IF(JM1.EQ.-1) THEN
15079 C  initialization
15080       ELSE IF(JM1.EQ.-2) THEN
15081 C  output of statistics
15082       ELSE
15083         WRITE(LO,'(1X,A,I10)')
15084      &    'PHO_REGFLA: invalid mother particle (JM1)',JM1
15085         CALL PHO_ABORT
15086       ENDIF
15087
15088       END
15089
15090 *$ CREATE PHO_SEAFLA.FOR
15091 *COPY PHO_SEAFLA
15092 CDECK  ID>, PHO_SEAFLA
15093       SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
15094 C**********************************************************************
15095 C
15096 C     selection of sea flavour content of particle IPAR
15097 C
15098 C     input:    IPAR    particle index in /POEVT1/
15099 C               CHMASS  available invariant string mass
15100 C                       positive mass --> use BAMJET method
15101 C                       negative mass --> SU(3) symmetric sea according
15102 C                       to values given in PARMDL(1-6)
15103 C               IPAR    -1 initialization
15104 C                       -2 output of statistics
15105 C
15106 C     output:   sea flavours according to PDG conventions
15107 C
15108 C**********************************************************************
15109       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15110       SAVE
15111
15112       PARAMETER ( EPS    =  0.1D0,
15113      &            DEPS   =  1.D-15)
15114
15115 C  input/output channels
15116       INTEGER LI,LO
15117       COMMON /POINOU/ LI,LO
15118 C  event debugging information
15119       INTEGER NMAXD
15120       PARAMETER (NMAXD=100)
15121       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15122      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15123       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15124      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15125 C  model switches and parameters
15126       CHARACTER*8 MDLNA
15127       INTEGER ISWMDL,IPAMDL
15128       DOUBLE PRECISION PARMDL
15129       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15130 C  some hadron information, will be deleted in future versions
15131       INTEGER NFS
15132       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15133       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15134
15135       IF(IPAR.GT.0) THEN
15136         IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15137 C  constant weights for sea
15138  15       CONTINUE
15139             SUM = 0.D0
15140             DO 40 K=1,NFSEA
15141               SUM = SUM + PARMDL(K)
15142  40         CONTINUE
15143             XI = DT_RNDM(SUM)*SUM
15144             SUM = 0.D0
15145             DO 50 K=1,NFSEA
15146               SUM = SUM + PARMDL(K)
15147               IF(XI.LE.SUM) GOTO 55
15148  50         CONTINUE
15149  55         CONTINUE
15150           IF(K.GT.NFSEA) GOTO 15
15151         ELSE
15152 C  mass dependent flavour sampling
15153  10       CONTINUE
15154             CALL PHO_FLAUX(CHMASS,K)
15155           IF(K.GT.NFSEA) GOTO 10
15156         ENDIF
15157         IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15158         IFL1 = K
15159         IFL2 = -K
15160         IF(IDEB(46).GE.10) THEN
15161           WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15162      &      IPAR,IFL1,IFL2,CHMASS
15163         ENDIF
15164       ELSE IF(IPAR.EQ.-1) THEN
15165 C  initialization
15166         NFSEA = NFS
15167       ELSE IF(IPAR.EQ.-2) THEN
15168 C  output of statistics
15169       ELSE
15170         WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15171         CALL PHO_ABORT
15172       ENDIF
15173
15174       END
15175
15176 *$ CREATE PHO_FLAUX.FOR
15177 *COPY PHO_FLAUX
15178 CDECK  ID>, PHO_FLAUX
15179       SUBROUTINE PHO_FLAUX(EQUARK,K)
15180 C***********************************************************************
15181 C
15182 C    auxiliary subroutine to select flavours
15183 C
15184 C********************************************************************
15185       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15186       SAVE
15187
15188       PARAMETER ( DEPS   =  1.D-14 )
15189
15190 C  input/output channels
15191       INTEGER LI,LO
15192       COMMON /POINOU/ LI,LO
15193 C  event debugging information
15194       INTEGER NMAXD
15195       PARAMETER (NMAXD=100)
15196       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15197      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15198       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15199      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15200 C  some hadron information, will be deleted in future versions
15201       INTEGER NFS
15202       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15203       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15204
15205       DIMENSION WGHT(9)
15206
15207 C  calculate weights for given energy
15208       IF(EQUARK.LT.QMASS(1)) THEN
15209         IF(IDEB(16).GE.5)
15210      &    WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15211      &      EQUARK
15212         WGHT(1) = 0.5D0
15213         WGHT(2) = 0.5D0
15214         WGHT(3) = 0.D0
15215         WGHT(4) = 0.D0
15216         SUM = 1.D0
15217       ELSE
15218         SUM = 0.D0
15219         DO 305 K=1,NFS
15220           IF(EQUARK.GT.QMASS(K)) THEN
15221             WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15222           ELSE
15223             WGHT(K) = 0.D0
15224           ENDIF
15225           SUM = SUM + WGHT(K)
15226  305    CONTINUE
15227       ENDIF
15228 C  sample flavours
15229       XI = SUM*(DT_RNDM(SUM)-DEPS)
15230       K = 0
15231       SUM = 0.D0
15232  400  CONTINUE
15233         K = K+1
15234         SUM = SUM + WGHT(K)
15235       IF(XI.GT.SUM) GOTO 400
15236 C  debug output
15237       IF(IDEB(16).GE.20) THEN
15238         WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15239       ENDIF
15240       END
15241
15242 *$ CREATE PHO_BETAF.FOR
15243 *COPY PHO_BETAF
15244 CDECK  ID>, PHO_BETAF
15245       DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15246 C********************************************************************
15247 C
15248 C     weights of different quark flavours
15249 C
15250 C********************************************************************
15251       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15252       SAVE
15253
15254       AX=0.D0
15255       BETX1=BET*X1
15256       IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15257       AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15258
15259       PHO_BETAF=AX+AY
15260
15261       END
15262
15263 *$ CREATE PHO_MCHECK.FOR
15264 *COPY PHO_MCHECK
15265 CDECK  ID>, PHO_MCHECK
15266       SUBROUTINE PHO_MCHECK(J1,IREJ)
15267 C********************************************************************
15268 C
15269 C    check parton momenta for fragmentation
15270 C
15271 C    input:      J1      first  string number
15272 C                        /POEVT1/
15273 C                        /POSTRG/
15274 C
15275 C    output:             /POEVT1/
15276 C                        /POSTRG/
15277 C                IREJ    0  successful
15278 C                        1  failure
15279 C
15280 C    in case of very small string mass:
15281 C                NNCH    mass label of string
15282 C                        0  string
15283 C                       -1  octett baryon / pseudo scalar meson
15284 C                        1  decuplett baryon / vector meson
15285 C                IBHAD   hadron number according to CPC,
15286 C                        string will be treated as resonance
15287 C                        (sometimes far off mass shell)
15288 C
15289 C    constant WIDTH ( 0.01GeV ) determines range of acceptance
15290 C
15291 C********************************************************************
15292       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15293       SAVE
15294
15295       PARAMETER ( WIDTH  =  0.01D0,
15296      &            DEPS   =  1.D-15 )
15297
15298 C  input/output channels
15299       INTEGER LI,LO
15300       COMMON /POINOU/ LI,LO
15301 C  event debugging information
15302       INTEGER NMAXD
15303       PARAMETER (NMAXD=100)
15304       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15305      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15306       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15307      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15308 C  model switches and parameters
15309       CHARACTER*8 MDLNA
15310       INTEGER ISWMDL,IPAMDL
15311       DOUBLE PRECISION PARMDL
15312       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15313
15314 C  standard particle data interface
15315       INTEGER NMXHEP
15316
15317       PARAMETER (NMXHEP=4000)
15318
15319       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15320       DOUBLE PRECISION PHEP,VHEP
15321       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15322      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15323      &                VHEP(4,NMXHEP)
15324 C  extension to standard particle data interface (PHOJET specific)
15325       INTEGER IMPART,IPHIST,ICOLOR
15326       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15327
15328 C  color string configurations including collapsed strings and hadrons
15329       INTEGER MSTR
15330       PARAMETER (MSTR=500)
15331       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15332       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15333      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15334      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15335 C  internal rejection counters
15336       INTEGER NMXJ
15337       PARAMETER (NMXJ=60)
15338       CHARACTER*10 REJTIT
15339       INTEGER IFAIL
15340       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15341
15342       IREJ = 0
15343 C  quark antiquark jet
15344       STRM = PHEP(5,NPOS(1,J1))
15345       IF(NCODE(J1).EQ.3) THEN
15346         CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15347      &    AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15348         IF(IDEB(18).GE.5)
15349      &    WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15350      &      'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15351      &      J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15352         IF(STRM.LT.AMPS) THEN
15353           IREJ = 1
15354           IFAIL(20) = IFAIL(20) + 1
15355           RETURN
15356         ELSE IF(STRM.LT.AMPS2) THEN
15357           IF(STRM.LT.(AMVE-WIDTH)) THEN
15358             NNCH(J1) = -1
15359             IBHAD(J1) = IPS
15360           ELSE
15361             NNCH(J1) = 1
15362             IBHAD(J1) = IVE
15363           ENDIF
15364         ELSE
15365           NNCH(J1) = 0
15366           IBHAD(J1) = 0
15367         ENDIF
15368 C  quark diquark or v.s. jet
15369       ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15370         CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15371      &              AM8,AM82,AM10,AM102,I8,I10)
15372         IF(IDEB(18).GE.5)
15373      &    WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15374      &            'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15375      &            J1,STRM,AM8,AM82,AM10,AM102
15376         IF(STRM.LT.AM8) THEN
15377           IREJ = 1
15378           IFAIL(19) = IFAIL(19) + 1
15379           RETURN
15380         ELSE IF(STRM.LT.AM82) THEN
15381           IF(STRM.LT.(AM10-WIDTH)) THEN
15382             NNCH(J1) = -1
15383             IBHAD(J1) = I8
15384           ELSE
15385             NNCH(J1) = 1
15386             IBHAD(J1) = I10
15387           ENDIF
15388         ELSE
15389           NNCH(J1) = 0
15390           IBHAD(J1) = 0
15391         ENDIF
15392 C  diquark a-diquark string
15393       ELSE IF(NCODE(J1).EQ.5) THEN
15394         CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15395      &              AM82,AM102)
15396         IF(IDEB(18).GE.5)
15397      &    WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15398      &            'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15399      &            J1,STRM,AM82,AM102
15400         IF(STRM.LT.AM82) THEN
15401           IREJ = 1
15402           IFAIL(19) = IFAIL(19) + 1
15403           RETURN
15404         ELSE
15405           NNCH(J1) = 0
15406           IBHAD(J1) = 0
15407         ENDIF
15408       ELSE IF(NCODE(J1).LT.0) THEN
15409         RETURN
15410       ELSE
15411         WRITE(LO,'(/,1X,2A,2I8)')  'PHO_MCHECK: ',
15412      &    'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15413         CALL PHO_ABORT
15414       ENDIF
15415       END
15416
15417 *$ CREATE PHO_POMCOR.FOR
15418 *COPY PHO_POMCOR
15419 CDECK  ID>, PHO_POMCOR
15420       SUBROUTINE PHO_POMCOR(IREJ)
15421 C********************************************************************
15422 C
15423 C    join quarks to gluons in case of too small masses
15424 C
15425 C    input:              /POEVT1/
15426 C                        /POSTRG/
15427 C                IREJ    -1          initialization
15428 C                        -2          output of statistics
15429 C
15430 C    output:             /POEVT1/
15431 C                        /POSTRG/
15432 C                IREJ    0  successful
15433 C                        1  failure
15434 C
15435 C
15436 C********************************************************************
15437       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15438       SAVE
15439
15440       PARAMETER ( EPS    =  1.D-10 )
15441
15442 C  input/output channels
15443       INTEGER LI,LO
15444       COMMON /POINOU/ LI,LO
15445 C  event debugging information
15446       INTEGER NMAXD
15447       PARAMETER (NMAXD=100)
15448       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15449      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15450       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15451      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15452 C  model switches and parameters
15453       CHARACTER*8 MDLNA
15454       INTEGER ISWMDL,IPAMDL
15455       DOUBLE PRECISION PARMDL
15456       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15457
15458 C  standard particle data interface
15459       INTEGER NMXHEP
15460
15461       PARAMETER (NMXHEP=4000)
15462
15463       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15464       DOUBLE PRECISION PHEP,VHEP
15465       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15466      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15467      &                VHEP(4,NMXHEP)
15468 C  extension to standard particle data interface (PHOJET specific)
15469       INTEGER IMPART,IPHIST,ICOLOR
15470       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15471
15472 C  color string configurations including collapsed strings and hadrons
15473       INTEGER MSTR
15474       PARAMETER (MSTR=500)
15475       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15476       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15477      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15478      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15479
15480       DIMENSION PJ(4)
15481
15482       IF(IREJ.EQ.-1) THEN
15483         ICTOT = 0
15484         ICCOR = 0
15485         RETURN
15486       ELSE IF(IREJ.EQ.-2) THEN
15487         WRITE(LO,'(/1X,A,2I8)')
15488      &    'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15489         RETURN
15490       ENDIF
15491 C
15492       IREJ = 0
15493 C
15494       NITER = 100
15495       ITER = 0
15496       ICTOT = ICTOT+ISTR
15497       IF(ISWMDL(25).LE.0) RETURN
15498 C  debug string entries
15499       IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15500 C
15501  50   CONTINUE
15502       ITER = ITER+1
15503       IF(ITER.GE.NITER) THEN
15504         IREJ = 1
15505         IF(IDEB(83).GE.2) THEN
15506           WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15507           IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15508         ENDIF
15509         RETURN
15510       ENDIF
15511 C
15512 C  check mass limits
15513       ISTRO = ISTR
15514       DO 100 I=1,ISTRO
15515         IF(NCODE(I).LT.0) GOTO 99
15516         J1 = NPOS(1,I)
15517         NRPOM = IPHIST(2,J1)
15518         IF(NRPOM.GE.100) GOTO 99
15519         CMASS0 = PHEP(5,J1)
15520 C  get masses
15521         IF(NCODE(I).EQ.3) THEN
15522           CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15523         ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15524           CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15525      &                AM1,AM2,AM3,AM4,IP1,IP2)
15526         ELSE IF(NCODE(I).EQ.5) THEN
15527           CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15528      &                AM1,AM2)
15529           AM3 = 0.D0
15530           AM4 = 0.D0
15531           IP1 = 0
15532           IP2 = 0
15533         ELSE IF(NCODE(I).EQ.7) THEN
15534           GOTO 99
15535         ELSE IF(NCODE(I).LT.0) THEN
15536           GOTO 99
15537         ELSE
15538           WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15539      &                            J1,NCODE(I)
15540           CALL PHO_ABORT
15541         ENDIF
15542         IF(IDEB(83).GE.5)
15543      &    WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15544      &      'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15545      &      I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15546 C  select masses to correct
15547         IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15548           DO 200 K=1,ISTRO
15549             IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15550               J2 = NPOS(1,K)
15551 C  join quarks to gluon
15552               IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15553 C  flavour check
15554                 IFL1 = 0
15555                 IFL2 = 0
15556                 PROB1 = 0.D0
15557                 PROB2 = 0.D0
15558                 KK1 = NPOS(2,I)
15559                 KK2 = NPOS(2,K)
15560                 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15561                   CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15562      &                   -(PHEP(1,KK1)+PHEP(1,KK2))**2
15563      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15564      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15565                   IFL1 = ABS(IDHEP(KK1))
15566                   IF(IFL1.GT.2) THEN
15567                     PROB1 = 0.1D0/MAX(CMASS,EPS)
15568                   ELSE
15569                     PROB1 = 0.9D0/MAX(CMASS,EPS)
15570                   ENDIF
15571                 ENDIF
15572                 KK1 = ABS(NPOS(3,I))
15573                 KK2 = ABS(NPOS(3,K))
15574                 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15575                   CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15576      &                   -(PHEP(1,KK1)+PHEP(1,KK2))**2
15577      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15578      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15579                   IFL2 = ABS(IDHEP(KK1))
15580                   IF(IFL2.GT.2) THEN
15581                     PROB2 = 0.1D0/MAX(CMASS,EPS)
15582                   ELSE
15583                     PROB2 = 0.9D0/MAX(CMASS,EPS)
15584                   ENDIF
15585                 ENDIF
15586                 IF(IFL1+IFL2.EQ.0) GOTO 99
15587 C  fusion possible
15588                 ICCOR = ICCOR+1
15589                 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15590                   JJ = 2
15591                   JE = 3
15592                 ELSE
15593                   JJ = 3
15594                   JE = 2
15595                 ENDIF
15596                 KK1 = ABS(NPOS(JJ,I))
15597                 KK2 = ABS(NPOS(JJ,K))
15598                 I1 = ABS(NPOS(JE,I))
15599                 I2 = KK1
15600                 IS = SIGN(1,I2-I1)
15601                 I2 = I2 - IS
15602                 K1 = KK2
15603                 K2 = ABS(NPOS(JE,K))
15604                 KS = SIGN(1,K2-K1)
15605                 K1 = K1 + KS
15606                 IP1 = NHEP+1
15607 C  copy mother partons of string I
15608                 DO 300 II=I1,I2,IS
15609                   CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15610      &              PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15611      &              ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15612  300            CONTINUE
15613 C  register gluon
15614                 DO 350 II=1,4
15615                   PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15616  350            CONTINUE
15617                 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15618      &            I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15619 C  copy mother partons of string K
15620                 DO 400 II=K1,K2,KS
15621                   CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15622      &              PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15623      &              ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15624  400            CONTINUE
15625 C  create new string entry
15626                 DO 450 II=1,4
15627                   PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15628  450            CONTINUE
15629                 IP2 = IPOS
15630                 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15631      &            PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15632      &            ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15633 C  delete string K in /POSTRG/
15634                 NCODE(K) = -999
15635 C  update string I in /POSTRG/
15636                 NPOS(1,I) = IPOS
15637                 NPOS(2,I) = IP1
15638                 NPOS(3,I) = -IP2
15639 C  calculate new CPC string codes
15640                 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15641      &            IPAR2(I),IPAR3(I),IPAR4(I))
15642                 GOTO 99
15643               ENDIF
15644             ENDIF
15645  200      CONTINUE
15646         ENDIF
15647  99     CONTINUE
15648  100  CONTINUE
15649       IF(IDEB(83).GE.20) THEN
15650         WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15651         IF(IDEB(83).GE.22) THEN
15652           CALL PHO_PRSTRG
15653           CALL PHO_PREVNT(0)
15654         ENDIF
15655       ENDIF
15656
15657       END
15658
15659 *$ CREATE PHO_MASCOR.FOR
15660 *COPY PHO_MASCOR
15661 CDECK  ID>, PHO_MASCOR
15662       SUBROUTINE PHO_MASCOR(IREJ)
15663 C********************************************************************
15664 C
15665 C    check and adjust parton momenta for fragmentation
15666 C
15667 C    input:      /POEVT1/
15668 C                /POSTRG/
15669 C                IREJ    -1          initialization
15670 C                        -2          output of statistics
15671 C
15672 C    output:     /POEVT1/
15673 C                /POSTRG/
15674 C                IREJ    0  successful
15675 C                        1  failure
15676 C
15677 C    in case of very small string mass:
15678 C       - direct manipulation of /POEVT1/ and /POEVT2/
15679 C       - string will be deleted from /POSTRG/ (label -99)
15680 C
15681 C********************************************************************
15682       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15683       SAVE
15684
15685       PARAMETER ( EPS    =  1.D-10,
15686      &            EMIN   =  0.3D0,
15687      &            DEPS   =  1.D-15)
15688
15689 C  input/output channels
15690       INTEGER LI,LO
15691       COMMON /POINOU/ LI,LO
15692 C  event debugging information
15693       INTEGER NMAXD
15694       PARAMETER (NMAXD=100)
15695       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15696      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15697       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15698      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15699 C  internal rejection counters
15700       INTEGER NMXJ
15701       PARAMETER (NMXJ=60)
15702       CHARACTER*10 REJTIT
15703       INTEGER IFAIL
15704       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15705 C  model switches and parameters
15706       CHARACTER*8 MDLNA
15707       INTEGER ISWMDL,IPAMDL
15708       DOUBLE PRECISION PARMDL
15709       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15710
15711 C  standard particle data interface
15712       INTEGER NMXHEP
15713
15714       PARAMETER (NMXHEP=4000)
15715
15716       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15717       DOUBLE PRECISION PHEP,VHEP
15718       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15719      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15720      &                VHEP(4,NMXHEP)
15721 C  extension to standard particle data interface (PHOJET specific)
15722       INTEGER IMPART,IPHIST,ICOLOR
15723       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15724
15725 C  color string configurations including collapsed strings and hadrons
15726       INTEGER MSTR
15727       PARAMETER (MSTR=500)
15728       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15729       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15730      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15731      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15732
15733       DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15734
15735       IF(IREJ.EQ.-1) THEN
15736         ICTOT = 0
15737         ICCOR = 0
15738         RETURN
15739       ELSE IF(IREJ.EQ.-2) THEN
15740         WRITE(LO,'(/1X,A,2I8/)')
15741      &    'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15742         RETURN
15743       ENDIF
15744
15745       IREJ = 0
15746       NITER = 100
15747       ITER = 0
15748       ICTOT = ICTOT+ISTR
15749       IF(ISWMDL(7).EQ.-1) RETURN
15750 C  debug /POSTRG/
15751       IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15752
15753       ITOUCH = 0
15754  50   CONTINUE
15755       ITER = ITER+1
15756       IF(ITER.GE.NITER) THEN
15757         IREJ = 1
15758         IF(IDEB(42).GE.2) THEN
15759           WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15760           IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15761         ENDIF
15762         RETURN
15763       ENDIF
15764
15765 C  check mass limits
15766       IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15767         IM1 = 1
15768         IM2 = ISTR
15769         IST = 1
15770       ELSE
15771         IM1 = ISTR
15772         IM2 = 1
15773         IST = -1
15774       ENDIF
15775       DO 100 I=IM1,IM2,IST
15776         J1 = NPOS(1,I)
15777         CMASS0 = PHEP(5,J1)
15778 C  get masses
15779         IF(NCODE(I).EQ.3) THEN
15780           CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15781         ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15782           CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15783      &                AM1,AM2,AM3,AM4,IP1,IP2)
15784         ELSE IF(NCODE(I).EQ.5) THEN
15785           CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15786      &              AM1,AM2)
15787           AM3 = 0.D0
15788           AM4 = 0.D0
15789           IP1 = 0
15790           IP2 = 0
15791         ELSE IF(NCODE(I).EQ.7) THEN
15792           AM1 = 0.15D0
15793           AM2 = 0.3D0
15794           AM3 = 0.765D0
15795           AM4 = 1.5D0
15796 *??????????????????????????????????
15797           IP1 = 23
15798           IP2 = 33
15799 *??????????????????????????????????
15800         ELSE IF(NCODE(I).LT.0) THEN
15801           GOTO 90
15802         ELSE
15803           WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15804      &                            J1,NCODE(I)
15805           CALL PHO_ABORT
15806         ENDIF
15807         IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15808      &    'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15809      &    I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15810 C  select masses to correct
15811         IBHAD(I) = 0
15812         NNCH(I) = 0
15813 C  correction needed?
15814 C  no resonances for diquark-antidiquark and gluon-gluon strings
15815         IF(NCODE(I).EQ.5) THEN
15816           IF(CMASS0.LT.1.3D0*AM1) THEN
15817             IF(ISWMDL(7).LE.2) THEN
15818               IBHAD(I) = 90
15819               NNCH(I)  = -1
15820               CHMASS   = AM1*1.3D0
15821             ELSE
15822               IREJ = 1
15823               RETURN
15824             ENDIF
15825           ENDIF
15826         ELSE
15827           INEED = 0
15828 C  resonances possible
15829           IF(ISWMDL(7).EQ.0) THEN
15830             IF(CMASS0.LT.AM1*0.99D0) THEN
15831               IBHAD(I) = IP1
15832               NNCH(I)  = -1
15833               CHMASS   = AM1
15834               INEED = 1
15835             ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15836               DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15837               DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15838               IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15839                 IBHAD(I) = IP1
15840                 NNCH(I)  = -1
15841                 CHMASS   = AM1
15842               ELSE
15843                 IBHAD(I) = IP2
15844                 NNCH(I)  = 1
15845                 CHMASS   = AM3
15846               ENDIF
15847             ENDIF
15848           ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15849             IF(CMASS0.LT.AM1*0.99) THEN
15850               IBHAD(I) = IP1
15851               NNCH(I) = -1
15852               CHMASS = AM1
15853               INEED = 1
15854             ENDIF
15855           ELSE IF(ISWMDL(7).EQ.3) THEN
15856             IF(CMASS0.LT.AM1) THEN
15857               IREJ = 1
15858               RETURN
15859             ENDIF
15860           ELSE
15861             WRITE(LO,'(/1X,A,I5)')
15862      &        'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15863             CALL PHO_ABORT
15864           ENDIF
15865         ENDIF
15866 C
15867 C  correction necessary?
15868         IF(IBHAD(I).NE.0) THEN
15869 C  find largest invar. mass
15870           IPOS = 0
15871           CMASS1 = -1.D0
15872           DO 200 J2=NHEP,3,-1
15873
15874             IF(ABS(ISTHEP(J2)).EQ.1) THEN
15875               IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15876                 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15877      &            'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15878                 CALL PHO_PREVNT(0)
15879               ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15880                 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15881      &                 -(PHEP(1,J1)+PHEP(1,J2))**2
15882      &                 -(PHEP(2,J1)+PHEP(2,J2))**2
15883      &                 -(PHEP(3,J1)+PHEP(3,J2))**2
15884                 IF(CMASS2.GT.CMASS1) THEN
15885                   IPOS=J2
15886                   CMASS1=CMASS2
15887                 ENDIF
15888               ENDIF
15889             ENDIF
15890
15891  200      CONTINUE
15892           J2 = IPOS
15893           IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15894             IF(INEED.EQ.1) THEN
15895               IREJ = 1
15896               RETURN
15897             ELSE
15898               IBHAD(I) = 0
15899               NNCH(I) = 0
15900               GOTO 90
15901             ENDIF
15902           ENDIF
15903           ISTA = ISTHEP(J1)
15904           ISTB = ISTHEP(J2)
15905           CMASS1 = SQRT(CMASS1)
15906           CMASS2 = PHEP(5,J2)
15907           IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15908           IREJ = 1
15909           IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15910      &      CHMASS,CMASS2,PC1,PC2,IREJ)
15911           IF(IREJ.NE.0) THEN
15912             IFAIL(24) = IFAIL(24)+1
15913             IF(IDEB(42).GE.2) THEN
15914               WRITE(LO,'(1X,A,2I4)')
15915      &          'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15916               IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15917             ENDIF
15918             IREJ = 1
15919             RETURN
15920           ENDIF
15921 C  momentum transfer
15922           DO 210 II=1,4
15923             PTR(II) = PHEP(II,J2)-PC2(II)
15924  210      CONTINUE
15925           IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15926      &      'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15927 C  copy parents of strings
15928 C  register partons belonging to first string
15929           IF(IDHEP(J1).EQ.90) THEN
15930             K1 = JMOHEP(1,J1)
15931             K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15932             ESUM = 0.D0
15933             DO 500 II=K1,K2
15934               ESUM = ESUM+PHEP(4,II)
15935  500        CONTINUE
15936             IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15937             DO 600 II=K1,K2
15938               FAC = PHEP(4,II)/ESUM
15939               DO 650 K=1,4
15940                 P1(K) = PHEP(K,II)+FAC*PTR(K)
15941  650          CONTINUE
15942               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15943      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15944      &          ICOLOR(2,II),IPOS,1)
15945  600        CONTINUE
15946             K1A = IPOS+K1-K2
15947             IF(JMOHEP(2,J1).GT.0) THEN
15948               II = JMOHEP(2,J1)
15949               FAC = PHEP(4,II)/ESUM
15950               DO 675 K=1,4
15951                 P1(K) = PHEP(K,II)+FAC*PTR(K)
15952  675          CONTINUE
15953               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15954      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15955      &          ICOLOR(2,II),IPOS,1)
15956             ENDIF
15957             K2A = -IPOS
15958           ELSE
15959             K1A = J1
15960             K2A = J2
15961           ENDIF
15962 C  register partons belonging to second string
15963           IF(IDHEP(J2).EQ.90) THEN
15964             CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15965             K1 = JMOHEP(1,J2)
15966             K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15967             ESUM = 0.D0
15968             DO 300 II=K1,K2
15969               ESUM = ESUM+PHEP(4,II)
15970  300        CONTINUE
15971             IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15972             DO 400 II=K1,K2
15973 **sr 28.12.2006 fix adopted from FLUKA
15974 C             FAC = PHEP(4,II)/ESUM
15975               IF (ABS(ESUM).GT.0.D0) THEN
15976                  FAC = PHEP(4,II)/ESUM
15977               ELSE
15978                  FAC = 1.0D0
15979               ENDIF
15980 **
15981               IF(IREJL.EQ.0) THEN
15982                 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15983                 P1(4) = P1(4)+FAC*DELE
15984               ELSE
15985                 DO 450 K=1,4
15986                   P1(K) = PHEP(K,II)-FAC*PTR(K)
15987  450            CONTINUE
15988               ENDIF
15989               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15990      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15991      &          ICOLOR(2,II),IPOS,1)
15992  400        CONTINUE
15993             K1B = IPOS+K1-K2
15994             IF(JMOHEP(2,J2).GT.0) THEN
15995               II = JMOHEP(2,J2)
15996               FAC = PHEP(4,II)/ESUM
15997               IF(IREJL.EQ.0) THEN
15998                 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15999                 P1(4) = P1(4)+FAC*DELE
16000               ELSE
16001                 DO 475 K=1,4
16002                   P1(K) = PHEP(K,II)-FAC*PTR(K)
16003  475            CONTINUE
16004               ENDIF
16005               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
16006      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
16007      &          ICOLOR(2,II),IPOS,1)
16008             ENDIF
16009             K2B = -IPOS
16010           ELSE
16011             K1B = J1
16012             K2B = J2
16013           ENDIF
16014 C  register first string/collapsed to hadron
16015           IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
16016             IF(NCODE(I).NE.5) THEN
16017               CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
16018      &          PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
16019 C  label string as collapsed to hadron/resonance
16020               NCODE(I)  = -99
16021               IDHEP(J1) = 92
16022             ELSE
16023               CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
16024      &          PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
16025               IDHEP(J1) = 91
16026             ENDIF
16027             NPOS(1,I) = IPOS
16028             NPOS(2,I) = K1A
16029             NPOS(3,I) = K2A
16030           ELSE
16031             CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
16032      &        PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
16033      &        ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
16034             IF(IDHEP(J1).EQ.90) THEN
16035               NPOS(1,IPHIST(1,J1)) = IPOS
16036               NPOS(2,IPHIST(1,J1)) = K1A
16037               NPOS(3,IPHIST(1,J1)) = K2A
16038 C  label string as collapsed to resonance-string
16039               IDHEP(J1) = 91
16040             ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
16041               IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
16042             ENDIF
16043           ENDIF
16044 C  register second string/hadron/parton
16045           CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
16046      &      PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
16047      &      ICOLOR(2,J2),IPOS,1)
16048           IF(IDHEP(J2).EQ.90) THEN
16049             NPOS(1,IPHIST(1,J2))=IPOS
16050             NPOS(2,IPHIST(1,J2))=K1B
16051             NPOS(3,IPHIST(1,J2))=K2B
16052 C  label string touched by momentum transfer
16053             IDHEP(J2) = 91
16054           ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
16055             IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
16056           ENDIF
16057           ICCOR = ICCOR+1
16058           ITOUCH = ITOUCH+1
16059 C  consistency checks
16060           IF(IDEB(42).GE.5) THEN
16061             CALL PHO_CHECK(-1,IDEV)
16062             IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
16063           ENDIF
16064 C  jump to next iteration
16065           GOTO 50
16066         ENDIF
16067  90     CONTINUE
16068  100  CONTINUE
16069 C  debug output
16070       IF(IDEB(42).GE.15) THEN
16071         IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
16072           WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
16073           CALL PHO_PREVNT(1)
16074         ENDIF
16075       ENDIF
16076       END
16077
16078 *$ CREATE PHO_PARCOR.FOR
16079 *COPY PHO_PARCOR
16080 CDECK  ID>, PHO_PARCOR
16081       SUBROUTINE PHO_PARCOR(MODE,IREJ)
16082 C********************************************************************
16083 C
16084 C    conversion of string partons (using JETSET masses)
16085 C
16086 C    input:      MODE    >0 position index of corresponding string
16087 C                        -1 initialization
16088 C                        -2 output of statistics
16089 C
16090 C    output:     /POSTRG/
16091 C                IREJ    1 combination of strings impossible
16092 C                        0 successful combination
16093 C
16094 C********************************************************************
16095       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16096       SAVE
16097
16098       PARAMETER ( DELM   =  0.005D0,
16099      &            DEPS   =  1.D-15,
16100      &            EPS    =  1.D-5)
16101
16102 C  input/output channels
16103       INTEGER LI,LO
16104       COMMON /POINOU/ LI,LO
16105 C  event debugging information
16106       INTEGER NMAXD
16107       PARAMETER (NMAXD=100)
16108       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16109      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16110       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16111      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16112 C  internal rejection counters
16113       INTEGER NMXJ
16114       PARAMETER (NMXJ=60)
16115       CHARACTER*10 REJTIT
16116       INTEGER IFAIL
16117       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16118 C  model switches and parameters
16119       CHARACTER*8 MDLNA
16120       INTEGER ISWMDL,IPAMDL
16121       DOUBLE PRECISION PARMDL
16122       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16123
16124 C  standard particle data interface
16125       INTEGER NMXHEP
16126
16127       PARAMETER (NMXHEP=4000)
16128
16129       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16130       DOUBLE PRECISION PHEP,VHEP
16131       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16132      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16133      &                VHEP(4,NMXHEP)
16134 C  extension to standard particle data interface (PHOJET specific)
16135       INTEGER IMPART,IPHIST,ICOLOR
16136       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16137
16138 C  color string configurations including collapsed strings and hadrons
16139       INTEGER MSTR
16140       PARAMETER (MSTR=500)
16141       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16142       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16143      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16144      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16145
16146       DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16147      &          PL(4,100),XMP(100),XML(100)
16148
16149       DOUBLE PRECISION PYMASS
16150
16151       IREJ = 0
16152       IMODE = MODE
16153 C
16154       IF(IMODE.GT.0) THEN
16155         ICH = 0
16156         I1 = JMOHEP(1,IMODE)
16157         I2 = ABS(JMOHEP(2,IMODE))
16158 C  copy to local field
16159         L = 0
16160         DO 100 I=I1,I2
16161           L = L+1
16162           DO 200 K=1,4
16163             PL(K,L) = PHEP(K,I)
16164  200      CONTINUE
16165           XMP(L) = PHEP(5,I)
16166
16167           XML(L) = PYMASS(IDHEP(I))
16168
16169  100    CONTINUE
16170         IPAR = L
16171         XMC = PHEP(5,IMODE)
16172         IF(IDEB(82).GE.20) THEN
16173           WRITE(LO,'(1X,A,I7,2I4)')
16174      &      'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16175      &      KEVENT,IMODE,L
16176           DO 150 I=1,L
16177             WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16178      &       XMP(I),XML(I)
16179  150      CONTINUE
16180         ENDIF
16181 C
16182 C  two parton configurations
16183 C  -----------------------------------------
16184         IF(IPAR.EQ.2) THEN
16185           XM1 = XML(1)
16186           XM2 = XML(2)
16187           IF((XM1+XM2).GE.XMC) THEN
16188             IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16189      &        'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16190      &        IMODE,XM1,XM2,XMC
16191             GOTO 990
16192           ENDIF
16193 C  conversion possible
16194           CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16195           IF(IREJ.NE.0) THEN
16196             IFAIL(36) = IFAIL(36)+1
16197             IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16198      &      'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16199      &        KEVENT,IMODE,XMC
16200             GOTO 990
16201           ENDIF
16202           ICH = 1
16203           DO 115 K=1,4
16204             PL(K,1) = PP1(K)
16205             PL(K,2) = PP2(K)
16206             XMP(1) = XM1
16207             XMP(2) = XM2
16208  115      CONTINUE
16209 C
16210 C  multi parton configurations
16211 C  ---------------------------------
16212         ELSE
16213 C
16214 C  random selection of string side to start with
16215           IF(DT_RNDM(XMC).LT.0.5D0) THEN
16216             K1 = 1
16217             K2 = IPAR
16218             KS = 1
16219           ELSE
16220             K1 = IPAR
16221             K2 = 1
16222             KS = -1
16223           ENDIF
16224           ITER = 0
16225 C
16226  300      CONTINUE
16227           IF(ITER.LT.4) THEN
16228             KK = K1
16229             K1 = K2
16230             K2 = KK
16231             KS = -KS
16232           ELSE
16233             GOTO 990
16234           ENDIF
16235           ITER = ITER+1
16236 C  select method
16237           IF(ITER.GT.2) GOTO 230
16238
16239 C  conversion according to color flow method
16240           IFAI = 0
16241           DO 210 II=K1,K2-KS,KS
16242             DO 215 IK=II+KS,K2,KS
16243               XM1 = XML(II)
16244               XM2 = XML(IK)
16245 *             IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16246 *    &          'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16247               IF((ABS(XM1-XMP(II)).GT.DELM)
16248      &           .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16249                 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16250                 IF(IREJ.NE.0) THEN
16251                   IFAIL(36) = IFAIL(36)+1
16252                   IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16253      &              'PHO_PARCOR: ',
16254      &              'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16255      &              KEVENT,IMODE,II,IK
16256                   IREJ = 0
16257                 ELSE
16258                   ICH = ICH+1
16259                   DO 220 KK=1,4
16260                     PL(KK,II) = PP1(KK)
16261                     PL(KK,IK) = PP2(KK)
16262  220              CONTINUE
16263                   XMP(II) = XM1
16264                   XMP(IK) = XM2
16265                   GOTO 219
16266                 ENDIF
16267               ELSE
16268                 GOTO 219
16269               ENDIF
16270  215        CONTINUE
16271             IFAI = II
16272  219        CONTINUE
16273  210      CONTINUE
16274           IF(IFAI.NE.0) GOTO 300
16275           GOTO 950
16276 C
16277  230      CONTINUE
16278 C
16279 C  conversion according to remainder method
16280           DO 350 I=K1,K2,KS
16281             XM1 = XML(I)
16282             IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16283               ICH = ICH+1
16284               IFAI = I
16285 C  conversion necessary
16286               DO 400 K=1,4
16287                 PB1(K) = PL(K,I)
16288                 PB2(K) = PHEP(K,IMODE)-PB1(K)
16289  400          CONTINUE
16290               XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16291               IF(XM2.LT.0.D0) THEN
16292                 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16293      &            'PHO_PARCOR: ',
16294      &            'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16295      &            I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16296                 GOTO 300
16297               ENDIF
16298               XM2 = SQRT(XM2)
16299               IF((XM1+XM2).GE.XMC) THEN
16300                 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16301      &            'PHO_PARCOR: ',
16302      &            'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16303      &            I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16304                 GOTO 300
16305               ENDIF
16306 C  conversion possible
16307               CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16308               IF(IREJ.NE.0) THEN
16309                 IFAIL(36) = IFAIL(36)+1
16310                 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16311      &            'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16312      &            ITER,IMODE,I
16313                 GOTO 300
16314               ENDIF
16315 C  calculate Lorentz transformation
16316               CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16317               IF(IREJ.NE.0) THEN
16318                 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16319      &            'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16320      &            ITER,IMODE,I
16321                 GOTO 300
16322               ENDIF
16323               IFAI = 0
16324 C  transform remaining partons
16325               DO 450 L=K1,K2,KS
16326                 IF(L.NE.I) THEN
16327                   CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16328                   DO 500 K=1,4
16329                     PL(K,L) = PP2(K)
16330  500              CONTINUE
16331                 ELSE
16332                   DO 550 K=1,4
16333                     PL(K,L) = PP1(K)
16334  550              CONTINUE
16335                 ENDIF
16336  450          CONTINUE
16337               XMP(I) = XM1
16338             ENDIF
16339  350      CONTINUE
16340         ENDIF
16341
16342 C  register transformed partons
16343  950      CONTINUE
16344           IREJ = 0
16345           IF(ICH.NE.0) THEN
16346             IP1 = NHEP+1
16347             L = 0
16348             DO 700 I=I1,I2
16349               L= L+1
16350               CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16351      &          PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16352      &          ICOLOR(2,I),IPOS,1)
16353  700        CONTINUE
16354             IP2 = IPOS
16355 C  register string
16356             CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16357      &        PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16358      &        IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16359 C  update /POSTRG/
16360             I = IPHIST(1,IMODE)
16361             NPOS(1,I) = IPOS
16362             NPOS(2,I) = IP1
16363             NPOS(3,I) = -IP2
16364           ENDIF
16365 C  debug output
16366           IF(IDEB(82).GE.20) THEN
16367             WRITE(LO,'(1X,A,I7,2I4)')
16368      &        'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16369      &        KEVENT,IMODE,L
16370             DO 850 I=1,L
16371               WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16372      &         XMP(I),XML(I)
16373  850        CONTINUE
16374             WRITE(LO,'(1X,A,2I5)')
16375      &        'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16376           ENDIF
16377           RETURN
16378 C  rejection
16379  990      CONTINUE
16380           IREJ = 1
16381           IF(IDEB(82).GE.3) THEN
16382             WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16383      &        'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16384      &         IFAI,IPAR,IMODE,XMC
16385             IF(IDEB(82).GE.5) THEN
16386               WRITE(LO,'(1X,A,I7,2I4)')
16387      &          'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16388      &          KEVENT,IMODE,IPAR
16389               DO 155 I=1,IPAR
16390                 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16391      &           XMP(I),XML(I)
16392  155          CONTINUE
16393             ENDIF
16394           ENDIF
16395           RETURN
16396
16397       ELSE IF(IMODE.EQ.-1) THEN
16398 C  initialization
16399         RETURN
16400
16401       ELSE IF(IMODE.EQ.-2) THEN
16402 C  final output
16403         RETURN
16404       ENDIF
16405       END
16406
16407 *$ CREATE PHO_STRING.FOR
16408 *COPY PHO_STRING
16409 CDECK  ID>, PHO_STRING
16410       SUBROUTINE PHO_STRING(IMODE,IREJ)
16411 C********************************************************************
16412 C
16413 C    calculation of string combinatorics, Lorentz boosts and
16414 C                   particle codes
16415 C
16416 C                - splitting of gluons
16417 C                - strings will be built up from pairs of partons
16418 C                  according to their color labels
16419 C                  with IDHEP(..) = -1
16420 C                - there can be other particles between to string partons
16421 C                  (these will be unchanged by string construction)
16422 C                - string mass fine correction
16423 C
16424 C    input:      IMODE    1  complete string processing
16425 C                        -1 initialization
16426 C                        -2 output of statistics
16427 C
16428 C    output:     /POSTRG/
16429 C                IREJ    1 combination of strings impossible
16430 C                        0 successful combination
16431 C                       50 rejection due to user cutoffs
16432 C
16433 C********************************************************************
16434       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16435       SAVE
16436
16437       PARAMETER ( DEPS   =  1.D-15,
16438      &            EPS    =  1.D-5 )
16439
16440 C  input/output channels
16441       INTEGER LI,LO
16442       COMMON /POINOU/ LI,LO
16443 C  event debugging information
16444       INTEGER NMAXD
16445       PARAMETER (NMAXD=100)
16446       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16447      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16448       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16449      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16450 C  general process information
16451       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16452       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16453 C  internal rejection counters
16454       INTEGER NMXJ
16455       PARAMETER (NMXJ=60)
16456       CHARACTER*10 REJTIT
16457       INTEGER IFAIL
16458       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16459 C  model switches and parameters
16460       CHARACTER*8 MDLNA
16461       INTEGER ISWMDL,IPAMDL
16462       DOUBLE PRECISION PARMDL
16463       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16464 C  hard cross sections and MC selection weights
16465       INTEGER Max_pro_2
16466       PARAMETER ( Max_pro_2 = 16 )
16467       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16468      &  MH_acc_1,MH_acc_2
16469       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16470       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16471      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16472      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16473      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16474      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16475
16476 C  standard particle data interface
16477       INTEGER NMXHEP
16478
16479       PARAMETER (NMXHEP=4000)
16480
16481       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16482       DOUBLE PRECISION PHEP,VHEP
16483       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16484      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16485      &                VHEP(4,NMXHEP)
16486 C  extension to standard particle data interface (PHOJET specific)
16487       INTEGER IMPART,IPHIST,ICOLOR
16488       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16489
16490 C  color string configurations including collapsed strings and hadrons
16491       INTEGER MSTR
16492       PARAMETER (MSTR=500)
16493       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16494       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16495      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16496      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16497 C  table of particle indices for recursive PHOJET calls
16498       INTEGER MAXIPX
16499       PARAMETER ( MAXIPX = 100 )
16500       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16501       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16502      &                IPOIX1,IPOIX2,IPOIX3
16503 C  some constants
16504       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16505       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16506      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16507
16508       IREJ = 0
16509       IF(IMODE.EQ.-1) THEN
16510         CALL PHO_POMCOR(-1)
16511         CALL PHO_MASCOR(-1)
16512         CALL PHO_PARCOR(-1,IREJ)
16513
16514         RETURN
16515       ELSE IF(IMODE.EQ.-2) THEN
16516         CALL PHO_POMCOR(-2)
16517         CALL PHO_MASCOR(-2)
16518         CALL PHO_PARCOR(-2,IREJ)
16519
16520         RETURN
16521       ENDIF
16522
16523 C  generate enhanced graphs
16524       IF(IPOIX2.GT.0) THEN
16525  200    CONTINUE
16526         I1 = MAX(1,IPOIX1)
16527         I2 = IPOIX2
16528         IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16529         KSPOMS = KSPOM-1
16530         KSREGS = KSREG
16531         KHPOMS = KHPOM
16532         KHDIRS = KHDIR
16533         IDDFS1 = IDIFR1
16534         IDDFS2 = IDIFR2
16535         IDDPOS = IDDPOM
16536         DO 110 I=I1,I2
16537           IPOIX3 = I
16538           KSPOM = 0
16539           KSREG = 0
16540           KHPOM = 0
16541           KHDIR = 0
16542           IF(IPORES(I).EQ.8) THEN
16543             KSPOM = 2
16544             LSPOM = 2
16545             LHPOM = 0
16546             LSREG = 0
16547             LHDIR = 0
16548             IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16549             CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16550      &                      LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16551             IF(IREJ.NE.0) THEN
16552               IF(IDEB(4).GE.2) THEN
16553                 WRITE(LO,'(/1X,A,I5)')
16554      &            'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16555                 CALL PHO_PREVNT(-1)
16556               ENDIF
16557               RETURN
16558             ENDIF
16559             KSPOM = KSPOMS+LSPOM
16560             KSREG = KSREGS+LSREG
16561             KHPOM = KHPOMS+LHPOM
16562             KHDIR = KHDIRS+LHDIR
16563           ELSE IF(IPORES(I).EQ.4) THEN
16564             ITEMP = ISWMDL(17)
16565             ISWMDL(17) = 0
16566             CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16567             ISWMDL(17) = ITEMP
16568             IF(IREJ.NE.0) THEN
16569               IF(IDEB(4).GE.2) THEN
16570                 WRITE(LO,'(/1X,A,I5)')
16571      &            'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16572                 CALL PHO_PREVNT(-1)
16573               ENDIF
16574               RETURN
16575             ENDIF
16576             KSDPO = KSDPO+1
16577             KSPOM = KSPOMS+KSPOM
16578             KSREG = KSREGS+KSREG
16579             KHPOM = KHPOMS+KHPOM
16580             KHDIR = KHDIRS+KHDIR
16581           ELSE
16582             IDIF1 = 1
16583             IDIF2 = 1
16584             IF(IPORES(I).EQ.5) THEN
16585               IDIF2 = 0
16586               KSTRG = KSTRG+1
16587             ELSE IF(IPORES(I).EQ.6) THEN
16588               IDIF1 = 0
16589               KSTRG = KSTRG+1
16590             ELSE
16591               KSLOO = KSLOO+1
16592             ENDIF
16593             ITEMP = ISWMDL(16)
16594             ISWMDL(16) = 0
16595             SPROB = 1.D0
16596             CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16597      &        0,MSOFT,MHARD,IREJ)
16598             ISWMDL(16) = ITEMP
16599             IF(IREJ.NE.0) THEN
16600               IF(IDEB(4).GE.2) THEN
16601                 WRITE(LO,'(/1X,A,I5)')
16602      &            'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16603                 CALL PHO_PREVNT(-1)
16604               ENDIF
16605               RETURN
16606             ENDIF
16607             KSPOM = KSPOMS+KSPOM
16608             KSREG = KSREGS+KSREG
16609             KHPOM = KHPOMS+KHPOM
16610             KHDIR = KHDIRS+KHDIR
16611           ENDIF
16612           IDIFR1 = IDDFS1
16613           IDIFR2 = IDDFS2
16614           IDDPOM = IDDPOS
16615  110    CONTINUE
16616         IF(IPOIX2.GT.I2) THEN
16617           IPOIX1 = I2+1
16618           GOTO 200
16619         ENDIF
16620       ENDIF
16621
16622 C  optional: split gluons to q-qbar pairs
16623       IF(ISWMDL(9).GT.0) THEN
16624         NHEPO = NHEP
16625         DO 30 I=3,NHEPO
16626           IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16627             ICG1=ICOLOR(1,I)
16628             ICG2=ICOLOR(2,I)
16629             IQ1 = 0
16630             IQ2 = 0
16631             DO 40 K=3,NHEPO
16632               IF(ICOLOR(1,K).EQ.-ICG1) THEN
16633                 IQ1 = K
16634                 IF(IQ1*IQ2.NE.0) GOTO 45
16635               ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16636                 IQ2 = K
16637                 IF(IQ1*IQ2.NE.0) GOTO 45
16638               ENDIF
16639  40         CONTINUE
16640             WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16641      &        'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16642             CALL PHO_ABORT
16643  45         CONTINUE
16644             CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16645             IF(IREJ.NE.0) THEN
16646               IF(IDEB(19).GE.5) THEN
16647                 WRITE(LO,'(/,1X,A)')
16648      &            'PHO_STRING: no gluon splitting possible'
16649                 CALL PHO_PREVNT(0)
16650               ENDIF
16651               RETURN
16652             ENDIF
16653           ENDIF
16654  30     CONTINUE
16655       ENDIF
16656
16657 C  construct strings and write entries sorted by strings
16658
16659       ISTR = ISTR+1
16660       NHEPO = NHEP
16661       DO 50 I=3,NHEPO
16662
16663         IF(ISTR.GT.MSTR) THEN
16664           WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16665      &      'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16666           CALL PHO_PREVNT(0)
16667           IREJ = 1
16668           RETURN
16669         ENDIF
16670
16671         IF(ISTHEP(I).EQ.1) THEN
16672 C  hadrons / resonances / clusters
16673           NPOS(1,ISTR) = I
16674           NPOS(2,ISTR) = 0
16675           NPOS(3,ISTR) = 0
16676           NPOS(4,ISTR) = abs(IPHIST(2,I))
16677           NCODE(ISTR) = -99
16678           IPHIST(1,I) = ISTR
16679           ISTR = ISTR+1
16680         ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16681 C  quark /diquark terminated strings
16682           ICOL1 = -ICOLOR(1,I)
16683           P1 = PHEP(1,I)
16684           P2 = PHEP(2,I)
16685           P3 = PHEP(3,I)
16686           P4 = PHEP(4,I)
16687           ICH1 = IPHO_CHR3(I,2)
16688           IBA1 = IPHO_BAR3(I,2)
16689           CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16690      &                P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16691      &                ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16692           JM1 = IPOS
16693
16694           NRPOM = 0
16695  65       CONTINUE
16696           DO 55 K=3,NHEPO
16697             IF(ISTHEP(K).EQ.-1)THEN
16698               IF(IDHEP(K).EQ.21) THEN
16699                 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16700                   ICOL1 = -ICOLOR(2,K)
16701                   GOTO 60
16702                 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16703                   ICOL1 = -ICOLOR(1,K)
16704                   GOTO 60
16705                 ENDIF
16706               ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16707                 ICOL1 = 0
16708                 GOTO 60
16709               ENDIF
16710             ENDIF
16711  55       CONTINUE
16712           WRITE(LO,'(/1X,A,I5)')
16713      &      'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16714           CALL PHO_ABORT
16715  60       CONTINUE
16716           P1 = P1+PHEP(1,K)
16717           P2 = P2+PHEP(2,K)
16718           P3 = P3+PHEP(3,K)
16719           P4 = P4+PHEP(4,K)
16720           NRPOM = MAX(NRPOM,IPHIST(1,K))
16721           ICH1 = ICH1+IPHO_CHR3(K,2)
16722           IBA1 = IBA1+IPHO_BAR3(K,2)
16723           CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16724      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16725      &      IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16726 C  further parton involved?
16727           IF(ICOL1.NE.0) GOTO 65
16728           JM2 = IPOS
16729 C  register string
16730           IGEN = IPHIST(2,K)
16731           CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16732      &                ISTR,IGEN,ICH1,IBA1,IPOS,1)
16733 C  store additional string information
16734           NPOS(1,ISTR) = IPOS
16735           NPOS(2,ISTR) = JM1
16736           NPOS(3,ISTR) = -JM2
16737           NPOS(4,ISTR) = abs(IPHIST(2,K))
16738 C  calculate CPC string codes
16739           CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16740      &                IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16741           ISTR = ISTR+1
16742         ENDIF
16743  50   CONTINUE
16744
16745       DO 150 I=3,NHEPO
16746
16747         IF(ISTR.GT.MSTR) THEN
16748           WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16749      &      'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16750           CALL PHO_PREVNT(0)
16751           IREJ = 1
16752           RETURN
16753         ENDIF
16754
16755         IF(ISTHEP(I).EQ.-1) THEN
16756 C  gluon loop-strings
16757           ICOL1 = -ICOLOR(1,I)
16758           P1 = PHEP(1,I)
16759           P2 = PHEP(2,I)
16760           P3 = PHEP(3,I)
16761           P4 = PHEP(4,I)
16762           IBA1 = 0
16763           ICH1 = 0
16764           CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16765      &                P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16766      &                ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16767           JM1 = IPOS
16768 C
16769           NRPOM = 0
16770  165      CONTINUE
16771           IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16772           DO 155 K=I,NHEPO
16773             IF(ISTHEP(K).EQ.-1)THEN
16774               IF(ICOLOR(1,K).EQ.ICOL1) THEN
16775                 ICOL1 = -ICOLOR(2,K)
16776                 GOTO 160
16777               ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16778                 ICOL1 = -ICOLOR(1,K)
16779                 GOTO 160
16780               ENDIF
16781             ENDIF
16782  155      CONTINUE
16783           WRITE(LO,'(/1X,A,I5)')
16784      &      'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16785           CALL PHO_ABORT
16786  160      CONTINUE
16787           P1 = P1+PHEP(1,K)
16788           P2 = P2+PHEP(2,K)
16789           P3 = P3+PHEP(3,K)
16790           P4 = P4+PHEP(4,K)
16791           NRPOM = MAX(NRPOM,IPHIST(1,K))
16792           CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16793      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16794      &      IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16795 C  further parton involved?
16796           IF(ICOL1.NE.0) GOTO 165
16797  170      CONTINUE
16798           JM2 = IPOS
16799 C  register string
16800           IGEN = IPHIST(2,K)
16801           CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16802      &                ISTR,IGEN,ICH1,IBA1,IPOS,1)
16803 C  store additional string information
16804           NPOS(1,ISTR) = IPOS
16805           NPOS(2,ISTR) = JM1
16806           NPOS(3,ISTR) = -JM2
16807           NPOS(4,ISTR) = abs(IPHIST(2,K))
16808 C  calculate CPC string codes
16809           CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16810      &                IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16811           ISTR = ISTR+1
16812         ENDIF
16813  150  CONTINUE
16814
16815       ISTR = ISTR-1
16816
16817       IF(IDEB(19).GE.17) THEN
16818         WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16819         CALL PHO_PREVNT(0)
16820       ENDIF
16821
16822 C  pomeron corrections
16823       CALL PHO_POMCOR(IREJ)
16824       IF(IREJ.NE.0) THEN
16825         IFAIL(38) = IFAIL(38)+1
16826         IF(IDEB(19).GE.3) THEN
16827           WRITE(LO,'(1X,A,I6)')
16828      &      'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16829           CALL PHO_PREVNT(-1)
16830         ENDIF
16831         RETURN
16832       ENDIF
16833
16834 C  string mass corrections
16835       CALL PHO_MASCOR(IREJ)
16836       IF(IREJ.NE.0) THEN
16837         IFAIL(34) = IFAIL(34)+1
16838         IF(IDEB(19).GE.3) THEN
16839           WRITE(LO,'(1X,A,I6)')
16840      &      'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16841           CALL PHO_PREVNT(-1)
16842         ENDIF
16843         RETURN
16844       ENDIF
16845
16846 C  parton mass corrections
16847       DO 100 I=1,ISTR
16848         IF(NCODE(I).GE.0) THEN
16849           CALL PHO_PARCOR(NPOS(1,I),IREJ)
16850           IF(IREJ.NE.0) THEN
16851             IFAIL(35) = IFAIL(35)+1
16852             IF(IDEB(19).GE.3) THEN
16853               WRITE(LO,'(1X,A,I6)')
16854      &          'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16855               CALL PHO_PREVNT(-1)
16856             ENDIF
16857             RETURN
16858           ENDIF
16859         ENDIF
16860  100  CONTINUE
16861
16862 C  statistics of hard processes
16863       DO 550 I=3,NHEP
16864         IF(ISTHEP(I).EQ.25) THEN
16865           K  = IMPART(I)
16866           II = IDHEP(I)
16867           MH_acc_2(K,II) = MH_acc_2(K,II)+1
16868         ENDIF
16869  550  CONTINUE
16870
16871 C  debug: write out strings
16872       IF(IDEB(19).GE.5) THEN
16873         IF(IDEB(19).GE.10)
16874      &    CALL PHO_CHECK(1,IDEV)
16875         IF(IDEB(19).GE.15) THEN
16876           CALL PHO_PREVNT(0)
16877         ELSE
16878           CALL PHO_PRSTRG
16879         ENDIF
16880       ENDIF
16881
16882       END
16883
16884 *$ CREATE PHO_STRFRA.FOR
16885 *COPY PHO_STRFRA
16886 CDECK  ID>, PHO_STRFRA
16887       SUBROUTINE PHO_STRFRA(IREJ)
16888 C********************************************************************
16889 C
16890 C     do all fragmentation of strings
16891 C
16892 C     output:  IREJ    0   successful
16893 C                      1   rejection
16894 C                     50   rejection due to user cutoffs
16895 C
16896 C********************************************************************
16897
16898       IMPLICIT NONE
16899
16900       SAVE
16901
16902 C  input/output channels
16903       INTEGER LI,LO
16904       COMMON /POINOU/ LI,LO
16905 C  some constants
16906       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16907       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16908      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16909 C  event debugging information
16910       INTEGER NMAXD
16911       PARAMETER (NMAXD=100)
16912       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16913      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16914       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16915      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16916 C  general process information
16917       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16918       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16919 C  model switches and parameters
16920       CHARACTER*8 MDLNA
16921       INTEGER ISWMDL,IPAMDL
16922       DOUBLE PRECISION PARMDL
16923       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16924 C  global event kinematics and particle IDs
16925       INTEGER IFPAP,IFPAB
16926       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16927       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16928
16929 C  standard particle data interface
16930       INTEGER NMXHEP
16931
16932       PARAMETER (NMXHEP=4000)
16933
16934       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16935       DOUBLE PRECISION PHEP,VHEP
16936       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16937      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16938      &                VHEP(4,NMXHEP)
16939 C  extension to standard particle data interface (PHOJET specific)
16940       INTEGER IMPART,IPHIST,ICOLOR
16941       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16942
16943 C  color string configurations including collapsed strings and hadrons
16944       INTEGER MSTR
16945       PARAMETER (MSTR=500)
16946       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16947       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16948      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16949      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16950
16951       INTEGER IREJ
16952
16953       DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16954
16955       INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16956      &        IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16957
16958       integer indx(500),indx_max
16959
16960       DOUBLE PRECISION DT_RNDM
16961       INTEGER ipho_pdg2id
16962       EXTERNAL DT_RNDM,ipho_pdg2id
16963
16964       DOUBLE PRECISION PYP,RQLUN
16965       INTEGER PYK
16966
16967       INTEGER MSTU,MSTJ
16968       DOUBLE PRECISION PARU,PARJ
16969       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16970
16971       INTEGER N,NPAD,K
16972       DOUBLE PRECISION P,V
16973       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16974
16975       DIMENSION IJOIN(100)
16976
16977       IREJ = 0
16978       IF(ABS(ISWMDL(6)).GT.3) THEN
16979         WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16980      &    'invalid value of ISWMDL(6)',ISWMDL(6)
16981         CALL PHO_ABORT
16982       ENDIF
16983
16984 C  popcorn suppression
16985         IF(PARMDL(134).GT.0.D0) THEN
16986           IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16987             MSTJ(12) = 2
16988           ELSE
16989             MSTJ(12) = 1
16990           ENDIF
16991         ENDIF
16992
16993 C  copy partons to fragmentation code JETSET
16994         IP = 0
16995         IP_old = 1
16996
16997         DO 300 J=1,ISTR
16998
16999 C  select partons with common production process
17000           IGEN = NPOS(4,J)
17001           if(IGEN.lt.0) goto 299
17002
17003           indx_max = 0
17004           DO 400 I=J,ISTR
17005             if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
17006
17007 C  write final particles/resonances to JETSET
17008               IF(NCODE(I).EQ.-99) THEN
17009                 II = NPOS(1,I)
17010                 IP = IP+1
17011                 P(IP,1) = PHEP(1,II)
17012                 P(IP,2) = PHEP(2,II)
17013                 P(IP,3) = PHEP(3,II)
17014                 P(IP,4) = PHEP(4,II)
17015                 P(IP,5) = PHEP(5,II)
17016                 K(IP,1) = 1
17017                 K(IP,2) = IDHEP(II)
17018                 K(IP,3) = 0
17019                 K(IP,4) = 0
17020                 K(IP,5) = 0
17021                 IPHIST(2,II) = IP
17022
17023                 if(indx_max.eq.500) then
17024                   WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
17025      &              'no space left in index vector (indx,Kevent)',
17026      &              indx_max,KEVENT
17027                   IREJ = 1
17028                   return
17029                 endif
17030
17031                 indx_max = indx_max+1
17032                 indx(indx_max) = II
17033 C  write partons to JETSET
17034               ELSE IF(NCODE(I).GE.0) THEN
17035                 K1 = JMOHEP(1,NPOS(1,I))
17036                 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
17037                 IJ = 0
17038                 DO II=K1,K2
17039                   IP = IP+1
17040                   P(IP,1) = PHEP(1,II)
17041                   P(IP,2) = PHEP(2,II)
17042                   P(IP,3) = PHEP(3,II)
17043                   P(IP,4) = PHEP(4,II)
17044                   P(IP,5) = PHEP(5,II)
17045                   K(IP,1) = 1
17046                   K(IP,2) = IDHEP(II)
17047                   K(IP,3) = 0
17048                   K(IP,4) = 0
17049                   K(IP,5) = 0
17050                   IPHIST(2,II) = IP
17051                   IJ = IJ+1
17052                   IJOIN(IJ) = IP
17053                   indx_max = indx_max+1
17054                   indx(indx_max) = II
17055
17056                 ENDDO
17057                 II = JMOHEP(2,NPOS(1,I))
17058                 IF((II.GT.0).AND.(II.NE.K1)) THEN
17059                   IP = IP+1
17060                   P(IP,1) = PHEP(1,II)
17061                   P(IP,2) = PHEP(2,II)
17062                   P(IP,3) = PHEP(3,II)
17063                   P(IP,4) = PHEP(4,II)
17064                   P(IP,5) = PHEP(5,II)
17065                   K(IP,1) = 1
17066                   K(IP,2) = IDHEP(II)
17067                   K(IP,3) = 0
17068                   K(IP,4) = 0
17069                   K(IP,5) = 0
17070                   IPHIST(2,II) = IP
17071                   IJ = IJ+1
17072                   IJOIN(IJ) = IP
17073                   indx_max = indx_max+1
17074                   indx(indx_max) = II
17075
17076                 ENDIF
17077                 N = IP
17078 C  connect partons to strings
17079
17080                 CALL PYJOIN(IJ,IJOIN)
17081
17082               ENDIF
17083
17084               NPOS(4,I) = -NPOS(4,I)
17085             endif
17086  400      continue
17087
17088 C  set Lund counter
17089           N = IP
17090           if(IP.eq.0) goto 299
17091
17092 C  hard final state evolution
17093           IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
17094             ISH = 0
17095             do 125 k1=1,indx_max
17096               I = indx(k1)
17097               IF(IPHIST(1,I).LE.-100) THEN
17098                 ISH = ISH+1
17099                 IJOIN(ISH) = I
17100               ENDIF
17101  125        continue
17102             IF(ISH.GE.2) THEN
17103               DO 130 K1=1,ISH
17104                 IF(IJOIN(K1).EQ.0) GOTO 130
17105                 I = IJOIN(K1)
17106                 IF((IPAMDL(102).EQ.1)
17107      &             .AND.(IPHIST(1,I).NE.-100)) GOTO 130
17108                 DO 135 K2=K1+1,ISH
17109                   IF(IJOIN(K2).EQ.0) GOTO 135
17110                   II = IJOIN(K2)
17111                   IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
17112                     PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
17113                     PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
17114                     RQLUN = MIN(PT1,PT2)
17115
17116                     IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
17117      &                'PHO_STRFRA: PYSHOW called',I,II,RQLUN
17118                     CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
17119
17120                     IJOIN(K1) = 0
17121                     IJOIN(K2) = 0
17122                     GOTO 130
17123                   ENDIF
17124  135            CONTINUE
17125  130          CONTINUE
17126             ENDIF
17127           ENDIF
17128
17129 C  fragment parton / hadron configuration (hadronization & decay)
17130
17131           IF(ISWMDL(6).NE.0) THEN
17132             II = MSTU(21)
17133             MSTU(21) = 1
17134
17135             CALL PYEXEC
17136
17137             MSTU(21) = II
17138 C  Lund warning?
17139             if(MSTU(28).ne.0) then
17140               IF(IDEB(22).GE.10) THEN
17141                 WRITE(LO,'(1X,A,I12,I3)')
17142      &            'PHO_STRFRA:(1) Lund code warning (EV/code)',
17143      &            KEVENT,MSTU(28)
17144                 CALL PHO_PREVNT(2)
17145               ENDIF
17146             endif
17147 C  event accepted?
17148             IF(MSTU(24).NE.0) THEN
17149               IF(IDEB(22).GE.2) THEN
17150                 WRITE(LO,'(1X,A,I12,I3)')
17151      &            'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
17152      &            KEVENT,MSTU(24)
17153                 CALL PHO_PREVNT(2)
17154               ENDIF
17155               IREJ = 1
17156               RETURN
17157             ENDIF
17158           ENDIF
17159
17160           IP = N
17161 C  change particle status in JETSET to avoid internal adjustments
17162           do k1=IP_old,IP
17163             K(k1,1) = K(k1,1)+1000
17164           enddo
17165           IP_old = IP+1
17166
17167  299      continue
17168  300    CONTINUE
17169
17170 C  restore original JETSET particle status codes
17171         do i=1,N
17172           K(i,1) = K(i,1)-1000
17173         enddo
17174
17175 *       IF(IDEB(22).GE.25) THEN
17176 *         WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17177 *    &      'particle/string system before fragmentation'
17178 *         CALL PHO_PREVNT(2)
17179 *       ENDIF
17180
17181 C  copy hadrons back to POEVT1 / POEVT2
17182
17183         IF(IP.GT.0) THEN
17184           NHEP1 = NHEP+1
17185
17186           NLINES = PYK(0,1)
17187
17188 C  copy hadrons back with full history information
17189           IF(IPAMDL(178).EQ.1) THEN
17190             DO 155 II=1,ISTR
17191               IF(NCODE(II).GE.0) THEN
17192                 K1 = IPHIST(2,NPOS(2,II))
17193                 K2 = IPHIST(2,-NPOS(3,II))
17194               ELSE IF(NCODE(II).EQ.-99) THEN
17195                 K1 = IPHIST(2,NPOS(1,II))
17196                 K2 = K1
17197               ELSE
17198                 GOTO 149
17199               ENDIF
17200               IFOUND = 0
17201               DO 160 J=1,NLINES
17202
17203                 IF(PYK(J,7).EQ.1) THEN
17204                   IPMOTH = PYK(J,15)
17205
17206                   IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17207
17208                     IBAM = ipho_pdg2id(PYK(J,8))
17209
17210                     IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17211                       IF(IDEB(22).GE.2) THEN
17212                         WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17213      &                    'LUND interface (1) rejection'
17214                         CALL PHO_PREVNT(2)
17215                       ENDIF
17216                       IREJ = 1
17217                       RETURN
17218                     ENDIF
17219                     IFOUND = IFOUND+1
17220
17221                     PX = PYP(J,1)
17222                     PY = PYP(J,2)
17223                     PZ = PYP(J,3)
17224                     HE = PYP(J,4)
17225                     XMB = PYP(J,5)**2
17226
17227 C  register parton/hadron
17228                     IS = 1
17229                     IF(IBAM.EQ.0) THEN
17230                       IF(ISWMDL(6).EQ.0) THEN
17231                         IS = -1
17232                       ELSE
17233                         IF(IDEB(22).GE.2) THEN
17234                           WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17235      &                      'LUND interface (2) rejection'
17236                           CALL PHO_PREVNT(2)
17237                         ENDIF
17238                         IREJ = 1
17239                         RETURN
17240                       ENDIF
17241                     ENDIF
17242
17243                     CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17244      &                PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17245
17246                     ISTHEP(IPOS) = 1
17247                   ENDIF
17248                 ENDIF
17249  160          CONTINUE
17250               IF(IFOUND.EQ.0) THEN
17251                 IF(IDEB(2).GE.2) THEN
17252                   WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17253      &            'no particles found for string (EVE,ISTR):',KEVENT,II
17254                 ENDIF
17255                 ISTHEP(NPOS(1,II)) = 2
17256               ENDIF
17257  149          CONTINUE
17258  155        CONTINUE
17259           ELSE
17260 C  copy hadrons back without history information
17261             JDAHEP(1,1) = NHEP1
17262             JDAHEP(1,2) = NHEP1
17263             DO 170 J=1,NLINES
17264
17265               IF(PYK(J,7).EQ.1) THEN
17266                 IBAM = ipho_pdg2id(PYK(J,8))
17267
17268                 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17269                   IF(IDEB(22).GE.2) THEN
17270                     WRITE(LO,'(/1X,A)')
17271      &                'PHO_STRFRA: LUND interface (3) rejection'
17272                     CALL PHO_PREVNT(2)
17273                   ENDIF
17274                   IREJ = 1
17275                   RETURN
17276                 ENDIF
17277
17278                 PX = PYP(J,1)
17279                 PY = PYP(J,2)
17280                 PZ = PYP(J,3)
17281                 HE = PYP(J,4)
17282                 XMB = PYP(J,5)**2
17283
17284 C  register parton/hadron
17285                 IS = 1
17286                 IF(IBAM.EQ.0) THEN
17287                   IF(ISWMDL(6).EQ.0) THEN
17288                     IS = -1
17289                   ELSE
17290                     IF(IDEB(22).GE.2) THEN
17291                       WRITE(LO,'(/1X,A)')
17292      &                  'PHO_STRFRA: LUND interface (4) rejection'
17293                       CALL PHO_PREVNT(2)
17294                     ENDIF
17295                     IREJ = 1
17296                     RETURN
17297                   ENDIF
17298                 ENDIF
17299
17300                 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17301      &            HE,J,0,0,0,IPOS,1)
17302
17303                 ISTHEP(IPOS) = 1
17304               ENDIF
17305  170        CONTINUE
17306             DO 180 II=1,ISTR
17307               IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17308      &          ISTHEP(NPOS(1,II)) = 2
17309  180        CONTINUE
17310           ENDIF
17311         ENDIF
17312
17313 C  debug event status
17314       IF(IDEB(22).GE.15) THEN
17315         WRITE(LO,'(//1X,A)')
17316      &    'PHO_STRFRA: particle system after fragmentation'
17317         CALL PHO_PREVNT(2)
17318       ENDIF
17319
17320       END
17321
17322 *$ CREATE PHO_EVEINI.FOR
17323 *COPY PHO_EVEINI
17324 CDECK  ID>, PHO_EVEINI
17325       SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17326 C********************************************************************
17327 C
17328 C     prepare /POEVT1/ for new event
17329 C
17330 C     first subroutine called for each event
17331 C
17332 C     input:   P1(4)  particle 1
17333 C              P2(4)  particle 2
17334 C              IMODE  0    general initialization
17335 C                     1    initialization of particles and kinematics
17336 C                     2    initialization after internal rejection
17337 C
17338 C     output:  IP1,IP2  index of interacting particles
17339 C
17340 C********************************************************************
17341       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17342       SAVE
17343
17344       DIMENSION P1(4),P2(4)
17345
17346       PARAMETER ( EPS    =  1.D-5,
17347      &            DEPS   =  1.D-15 )
17348
17349 C  input/output channels
17350       INTEGER LI,LO
17351       COMMON /POINOU/ LI,LO
17352 C  event debugging information
17353       INTEGER NMAXD
17354       PARAMETER (NMAXD=100)
17355       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17356      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17357       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17358      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17359 C  model switches and parameters
17360       CHARACTER*8 MDLNA
17361       INTEGER ISWMDL,IPAMDL
17362       DOUBLE PRECISION PARMDL
17363       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17364 C  general process information
17365       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17366       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17367 C  gamma-lepton or gamma-hadron vertex information
17368       INTEGER IGHEL,IDPSRC,IDBSRC
17369       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17370      &                 RADSRC,AMSRC,GAMSRC
17371       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17372      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17373      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17374 C  global event kinematics and particle IDs
17375       INTEGER IFPAP,IFPAB
17376       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17377       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17378 C  energy-interpolation table
17379       INTEGER IEETA2
17380       PARAMETER ( IEETA2 = 20 )
17381       INTEGER ISIMAX
17382       DOUBLE PRECISION SIGTAB,SIGECM
17383       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17384 C  cross sections
17385       INTEGER IPFIL,IFAFIL,IFBFIL
17386       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17387      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17388      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17389      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17390      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17391       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17392      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17393      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17394      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17395      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17396      &                IPFIL,IFAFIL,IFBFIL
17397 C  color string configurations including collapsed strings and hadrons
17398       INTEGER MSTR
17399       PARAMETER (MSTR=500)
17400       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17401       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17402      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17403      &                NNCH(MSTR),IBHAD(MSTR),ISTR
17404
17405 C  standard particle data interface
17406       INTEGER NMXHEP
17407
17408       PARAMETER (NMXHEP=4000)
17409
17410       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17411       DOUBLE PRECISION PHEP,VHEP
17412       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17413      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17414      &                VHEP(4,NMXHEP)
17415 C  extension to standard particle data interface (PHOJET specific)
17416       INTEGER IMPART,IPHIST,ICOLOR
17417       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17418
17419 C  table of particle indices for recursive PHOJET calls
17420       INTEGER MAXIPX
17421       PARAMETER ( MAXIPX = 100 )
17422       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17423       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17424      &                IPOIX1,IPOIX2,IPOIX3
17425 C  event weights and generated cross section
17426       INTEGER IPOWGC,ISWCUT,IVWGHT
17427       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17428       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17429      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17430
17431       DIMENSION IM(2)
17432
17433 C  reset debug variables
17434       KSPOM  = 0
17435       KHPOM  = 0
17436       KSREG  = 0
17437       KHDIR  = 0
17438       KSTRG  = 0
17439       KHTRG  = 0
17440       KSLOO  = 0
17441       KHLOO  = 0
17442       KSDPO  = 0
17443       KSOFT  = 0
17444       KHARD  = 0
17445 C
17446       IDNODF = 0
17447       IDIFR1 = 0
17448       IDIFR2 = 0
17449       IDDPOM = 0
17450       ISTR   = 0
17451       IPOIX1 = 0
17452       IF(ISWMDL(14).GT.0) IPOIX1 = 1
17453       IPOIX2 = 0
17454       IPOIX3 = 0
17455 C  reset /POEVT1/ and /POEVT2/
17456       CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17457      &            0,0,0,0,IPOS,0)
17458       CALL PHO_SELCOL(0,0,0,0,0,0,0)
17459       DO 15 I=0,10
17460         IPOWGC(I) = 0
17461  15   CONTINUE
17462
17463 C  initialization of particle kinematics
17464
17465 C  lepton-photon/hadron-photon vertex and initial particles
17466         IM(1) = 0
17467         IM(2) = 0
17468         IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17469           CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17470      &      PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17471         ELSE
17472           CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17473      &      P1(4),0,0,0,0,IP1,1)
17474         ENDIF
17475         IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17476           CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17477      &      PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17478         ELSE
17479           CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17480      &      P2(4),0,0,0,0,IP2,1)
17481         ENDIF
17482         IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17483           CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17484      &      PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17485           CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17486      &      P1(4),0,0,0,0,IP1,1)
17487         ENDIF
17488         IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17489           CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17490      &      PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17491           CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17492      &      P2(4),0,0,0,0,IP2,1)
17493         ENDIF
17494         NEVHEP = KACCEP
17495
17496       IF(IMODE.LE.1) THEN
17497 C  CMS energy
17498         ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17499      &           -(P1(3)+P2(3))**2)
17500 *       CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17501         PMASS(1) = PHEP(5,IP1)
17502         PVIRT(1) = 0.D0
17503         IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17504         PMASS(2) = PHEP(5,IP2)
17505         PVIRT(2) = 0.D0
17506         IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17507       ENDIF
17508
17509 C  cross section calculations
17510
17511       IF(IMODE.NE.1) THEN
17512         IP = 1
17513         CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17514      &              ECM,PVIRT(1),PVIRT(2))
17515       ENDIF
17516
17517       IF(IMODE.LE.0) THEN
17518 C  effective cross section
17519         SIGGEN(3) = 0.D0
17520         IF(ISWMDL(2).ge.1) THEN
17521           IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17522      &      -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17523      &      -SIGHDD-SIGDIR
17524           IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17525           IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17526           IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17527           IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17528           IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17529           IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17530           IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17531 C  simulate only hard scatterings
17532         ELSE
17533           IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17534           IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17535         ENDIF
17536
17537       ENDIF
17538
17539 C  reset of mother/daughter relations only (IMODE = 2)
17540
17541 C  debug output
17542       IF(IDEB(63).GE.15) THEN
17543         WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17544      &    '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17545         IF(IMODE.LE.0) THEN
17546           WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17547      &      'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17548      &      FSUP,FSUH,FSUD
17549           ONEM = -1.D0
17550           ITMP = IDEB(57)
17551           IDEB(57) = MAX(5,ITMP)
17552           CALL PHO_XSECT(1,0,ONEM)
17553           IDEB(57) = ITMP
17554         ENDIF
17555         CALL PHO_PREVNT(0)
17556       ENDIF
17557
17558       END
17559
17560 *$ CREATE PHO_CSINT.FOR
17561 *COPY PHO_CSINT
17562 CDECK  ID>, PHO_CSINT
17563       SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17564 C********************************************************************
17565 C
17566 C     calculate cross sections by interpolation
17567 C
17568 C     input:   IP          particle combination
17569 C              IFPA/B      particle PDG number
17570 C              IHLA/B      particle helicity (photons only)
17571 C              ECM         c.m. energy (GeV)
17572 C              PVIR2A      virtuality of particle A (GeV**2, positive)
17573 C              PVIR2B      virtuality of particle B (GeV**2, positive)
17574 C
17575 C     output:  cross sections stored in /POCSEC/
17576 C
17577 C********************************************************************
17578       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17579       SAVE
17580
17581       PARAMETER ( EPS    =  1.D-5,
17582      &            DEPS   =  1.D-15 )
17583
17584 C  input/output channels
17585       INTEGER LI,LO
17586       COMMON /POINOU/ LI,LO
17587 C  some constants
17588       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17589       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17590      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17591 C  event debugging information
17592       INTEGER NMAXD
17593       PARAMETER (NMAXD=100)
17594       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17595      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17596       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17597      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17598 C  model switches and parameters
17599       CHARACTER*8 MDLNA
17600       INTEGER ISWMDL,IPAMDL
17601       DOUBLE PRECISION PARMDL
17602       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17603 C  energy-interpolation table
17604       INTEGER IEETA2
17605       PARAMETER ( IEETA2 = 20 )
17606       INTEGER ISIMAX
17607       DOUBLE PRECISION SIGTAB,SIGECM
17608       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17609 C  cross sections
17610       INTEGER IPFIL,IFAFIL,IFBFIL
17611       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17612      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17613      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17614      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17615      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17616       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17617      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17618      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17619      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17620      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17621      &                IPFIL,IFAFIL,IFBFIL
17622 C  hard cross sections and MC selection weights
17623       INTEGER Max_pro_2
17624       PARAMETER ( Max_pro_2 = 16 )
17625       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17626      &  MH_acc_1,MH_acc_2
17627       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17628       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17629      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17630      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17631      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17632      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17633
17634       DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17635
17636       dimension PD(-6:6),FH_T(2),FH_L(2)
17637
17638 C  debug
17639       IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17640      &  'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17641      &  IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17642
17643 C  check currently stored cross sections
17644       IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17645      &   .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17646      &   .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17647 C  nothing to calculate
17648         IF(IDEB(15).GE.20)
17649      &    WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17650         RETURN
17651       ELSE
17652
17653 C  copy to local fields
17654         IFPAP(1) = IFPA
17655         IFPAP(2) = IFPB
17656         IHEL(1)  = IHLA
17657         IHEL(2)  = IHLB
17658         PVIRT(1) = PVIR2A
17659         PVIRT(2) = PVIR2B
17660
17661 C  load cross sections from interpolation table
17662         IF(ECM.LE.SIGECM(IP,1)) THEN
17663           I1 = 1
17664           I2 = 2
17665         ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17666           DO 50 I=2,ISIMAX
17667             IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17668  50       CONTINUE
17669  200      CONTINUE
17670           I1 = I-1
17671           I2 = I
17672         ELSE
17673           WRITE(LO,'(/1X,A,2E12.3)')
17674      &      'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17675           CALL PHO_PREVNT(-1)
17676           I1 = ISIMAX-1
17677           I2 = ISIMAX
17678         ENDIF
17679         FAC2=0.D0
17680         IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17681      &                    /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17682         FAC1=1.D0-FAC2
17683
17684 C  cross section dependence on photon virtualities
17685         DO 140 K=1,2
17686           FSUP(K) = 1.D0
17687           FSUD(K) = 1.D0
17688           FSUH(K) = 1.D0
17689           IF(IFPAP(K).EQ.22) THEN
17690             IF(ISWMDL(10).GE.1) THEN
17691               FSUP(K) = 0.D0
17692               FSUT(K) = 0.D0
17693               FSUL(K) = 0.D0
17694               FSUH(K) = 0.D0
17695 C  GVDM factors for transverse/longitudinal photons
17696               DO 150 I=1,3
17697                 FSUT(K) = FSUT(K)+PARMDL(26+I)
17698      &                   /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17699                 FSUL(K) = FSUL(K)
17700      &                   +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17701      &                   /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17702  150          CONTINUE
17703               FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17704 C  transverse part
17705               IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17706                 FSUP(K) = FSUT(K)
17707                 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17708 C  diffraction of trans. photons corresponds mainly to leading twist
17709                 FSUD(K) = 1.D0
17710               ENDIF
17711 C  longitudinal (scalar) part
17712               IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17713                 FSUP(K) = FSUP(K)+FSUL(K)
17714                 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17715 C  diffraction of long. photons corresponds mainly to higher twist
17716                 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17717      &                   /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17718      &                   /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17719               ENDIF
17720 C  debug output
17721               if(ideb(15).ge.10) then
17722                 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17723      &            'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17724      &            K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17725               endif
17726             ENDIF
17727           ENDIF
17728  140    CONTINUE
17729
17730         FACP = FSUP(1)*FSUP(2)
17731         FACH = FSUH(1)*FSUH(2)
17732         FACD = FSUD(1)*FSUD(2)
17733
17734 C  matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17735
17736         if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17737      &     .and.(IPAMDL(117).gt.0)) then
17738 C  check kinematic limit
17739           Q2_max = max(PVIRT(1),PVIRT(2))
17740           Q2_min = min(PVIRT(1),PVIRT(2))
17741           if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17742
17743 C  calculate F2 from current parton density
17744             if(PVIRT(1).gt.PVIRT(2)) then
17745               K = 2
17746             else
17747               K = 1
17748             endif
17749             Q2 = Q2_max
17750             P2 = Q2_min
17751             X = Q2/(ECM**2+Q2+P2)
17752             call pho_actpdf(IFPAP(K),K)
17753             call pho_pdf(K,X,Q2,P2,PD)
17754 C  light quark contribution
17755             F2_light = 0.D0
17756             do j=1,3
17757               F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17758             enddo
17759 C  heavy quark contribution
17760             call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17761             F2_c = 2.D0*4.D0/9.D0*xpdf_c
17762             F2 = (F2_light+F2_c)
17763
17764 C  calculate model prediction
17765             SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17766             SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17767             CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17768
17769             if(ISWMDL(10).ge.2) then
17770
17771 C  calculate all helicity combinations
17772               if(IPAMDL(115).eq.0) then
17773                 SIGDIH    = HSig(14)
17774                 SIGSRH(1) = HSig(10)+HSig(11)
17775                 SIGSRH(2) = HSig(12)+HSig(13)
17776                 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17777 C  photon helicity factors
17778                 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17779                 FH_L(1) = 1.D0-FH_T(1)
17780                 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17781                 FH_L(2) = 1.D0-FH_T(2)
17782                 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17783      &                  + SIGDIH*FH_T(1)*FH_T(2)
17784      &                  + SIGSRH(1)*FH_T(1)*FSUT(2)
17785      &                  + SIGSRH(2)*FSUT(1)*FH_T(2)
17786                 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17787      &                  + SIGDIH*FH_T(1)*FH_L(2)
17788      &                  + SIGSRH(1)*FH_T(1)*FSUL(2)
17789      &                  + SIGSRH(2)*FSUT(1)*FH_L(2)
17790                 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17791      &                  + SIGDIH*FH_L(1)*FH_T(2)
17792      &                  + SIGSRH(1)*FH_L(1)*FSUT(2)
17793      &                  + SIGSRH(2)*FSUL(1)*FH_T(2)
17794                 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17795      &                  + SIGDIH*FH_L(1)*FH_L(2)
17796      &                  + SIGSRH(1)*FH_L(1)*FSUL(2)
17797      &                  + SIGSRH(2)*FSUL(1)*FH_L(2)
17798               else
17799 C  use explicit PDF virtuality dependence (pre-tabulated)
17800                 SIGDIH    = HSig(14)
17801                 SIGSRH(1) = HSig(10)+HSig(11)
17802                 SIGSRH(2) = HSig(12)+HSig(13)
17803                 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17804                 write(LO,*) ' PHO_CSINT: invalid option for F2 matching'
17805                 stop
17806 *               CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17807 *    &                          Max_pro_2,3,4,1)
17808 *               SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17809 *    &                  + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17810 *               SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17811 *    &                  + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17812 *               SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17813 *    &                  + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17814 *               SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17815 *    &                  + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17816               endif
17817               Xnu = Ecm*Ecm+Q2+P2
17818               F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17819      &             *137.D0/GeV2mb
17820               if(K.eq.2) then
17821                 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17822                 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17823      &               -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17824               else
17825                 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17826                 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17827      &               -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17828               endif
17829
17830             else
17831
17832 C  assume sig_eff = sigtot
17833               SIGDIH    = HSig(14)
17834               SIGSRH(1) = HSig(10)+HSig(11)
17835               SIGSRH(2) = HSig(12)+HSig(13)
17836               SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17837               SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17838      &                +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17839               Xnu = Ecm*Ecm+Q2+P2
17840               F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17841      &             *137.D0/GeV2mb
17842               F2m = F2_fac*SIGeff
17843               F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17844             endif
17845 *           write(LO,*) ' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17846 *           write(LO,*) ' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
17847
17848 C  global factor to re-scale suppression of soft contributions
17849             Fcorr = (F2-F2m+F2s)/F2s
17850 *           write(LO,*) ' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
17851             FACP = FACP*Fcorr
17852
17853           endif
17854         endif
17855
17856         SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17857         SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17858         SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17859         J = 2
17860         DO 5 I=0,4
17861           DO 6 K=0,4
17862             J = J+1
17863             SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17864      &                  *FACP**2
17865  6        CONTINUE
17866  5      CONTINUE
17867
17868         SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17869         SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17870 C  suppression of multi-pomeron graphs (diffraction)
17871         SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17872      &             *FACP*FSUP(2)*FSUD(1)
17873         SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17874      &             *FACP*FSUP(1)*FSUD(2)
17875         SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17876      &             *FACP*FSUP(2)*FSUD(1)
17877         SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17878      &             *FACP*FSUP(1)*FSUD(2)
17879         SIGLDD    = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17880      &             *FACP**2*FACD
17881         SIGHDD    = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17882         SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17883      &             *FACP**2
17884         SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17885      &             *FACP*FSUP(2)*FSUD(1)
17886         SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17887      &             *FACP*FSUP(2)*FSUD(1)
17888         SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17889      &             *FACP*FSUP(1)*FSUD(2)
17890         SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17891      &             *FACP*FSUP(1)*FSUD(2)
17892         SIGLOO    = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17893         SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17894      &             *FACP**2
17895         SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17896      &             *FACP**2
17897         SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17898      &             *FACP**2
17899         SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17900      &             *FACP**2
17901
17902 C  corrections due to photon virtuality dependence of PDFs
17903         if(iswmdl(2).eq.1) then
17904           CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17905 C  minimum bias event generation
17906           IF(IPAMDL(115).GE.1) THEN
17907 C  all the virtuality dependence is given by PDF parametrization
17908             SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17909             IF(IPAMDL(116).GE.2) THEN
17910 C  direct interaction according to full QPM calculation
17911               SIGDIH = HSig(14)
17912               SIGSRH(1) = HSig(10)+HSig(11)
17913               SIGSRH(2) = HSig(12)+HSig(13)
17914             ELSE
17915 C  direct interaction suppressed according to helicity factor
17916               SIGDIH = HSig(14)*FACH
17917               SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17918               SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17919             ENDIF
17920             write(LO,*) ' PHO_CSINT: option not supported yet'
17921             stop
17922           ELSE
17923 C  rescale relevant hard processes
17924             SIGDIH    = HSig(14)
17925             SIGSRH(1) = HSig(10)+HSig(11)
17926             SIGSRH(2) = HSig(12)+HSig(13)
17927             SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17928             SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17929      &              +SIGSRH(2)*FSUP(1)*FSUH(2)
17930             SIGINE = SIGtmp+SIGDIR
17931             SIGTOT = SIGINE+SIGELA
17932           ENDIF
17933         else
17934 C  only hard interactions
17935           CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17936           SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17937           SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17938           SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17939           SIGHAR = HSig(9)*FACH
17940         endif
17941
17942         SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17943         SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17944         SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17945         J = 39
17946         DO 9 I=1,4
17947           DO 10 K=1,4
17948             J = J+1
17949             SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17950  10       CONTINUE
17951  9      CONTINUE
17952         SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17953         SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17954
17955         IPFIL  = IP
17956         IFAFIL = IFPA
17957         IFBFIL = IFPB
17958         ECMFIL = ECM
17959         P2AFIL = PVIR2A
17960         P2BFIL = PVIR2B
17961
17962         IF(IDEB(15).GE.20)
17963      &    WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17964
17965       ENDIF
17966
17967       END
17968
17969 *$ CREATE PHO_PRIMKT.FOR
17970 *COPY PHO_PRIMKT
17971 CDECK  ID>, PHO_PRIMKT
17972       SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17973 C***********************************************************************
17974 C
17975 C    give primordial kt to partons entering hard scatterings and
17976 C    remants connected to hard parton-parton interactions by color flow
17977 C
17978 C    input:  IMODE   -2   output of statistics
17979 C                    -1   initialization
17980 C                     1   sampling of primordial kt
17981 C            IF           first entry in /POEVT1/ to check
17982 C            IL           last entry in /POEVT1/ to check
17983 C            PTCUT        current value of PTCUT to distinguish
17984 C                         between soft and hard
17985 C
17986 C    output: IREJ     0   success
17987 C                     1   failure
17988 C
17989 C***********************************************************************
17990
17991       IMPLICIT NONE
17992
17993       SAVE
17994
17995       DOUBLE PRECISION DEPS
17996       PARAMETER ( DEPS = 1.D-15 )
17997
17998       INTEGER IMODE,IF,IL,IREJ
17999       DOUBLE PRECISION PTCUT
18000
18001 C  input/output channels
18002       INTEGER LI,LO
18003       COMMON /POINOU/ LI,LO
18004 C  event debugging information
18005       INTEGER NMAXD
18006       PARAMETER (NMAXD=100)
18007       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18008      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18009       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18010      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18011 C  model switches and parameters
18012       CHARACTER*8 MDLNA
18013       INTEGER ISWMDL,IPAMDL
18014       DOUBLE PRECISION PARMDL
18015       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18016 C  some constants
18017       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18018       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18019      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18020 C  data of c.m. system of Pomeron / Reggeon exchange
18021       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18022       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18023      &                 SIDP,CODP,SIFP,COFP
18024       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18025      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18026      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18027 C  hard scattering data
18028       INTEGER MSCAHD
18029       PARAMETER ( MSCAHD = 50 )
18030       INTEGER LSCAHD,LSC1HD,LSIDX,
18031      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
18032       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
18033       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
18034      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
18035      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
18036      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
18037      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
18038      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
18039      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
18040
18041 C  standard particle data interface
18042       INTEGER NMXHEP
18043
18044       PARAMETER (NMXHEP=4000)
18045
18046       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18047       DOUBLE PRECISION PHEP,VHEP
18048       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18049      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18050      &                VHEP(4,NMXHEP)
18051 C  extension to standard particle data interface (PHOJET specific)
18052       INTEGER IMPART,IPHIST,ICOLOR
18053       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18054
18055       DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
18056       DIMENSION PTS(0:2,5),XP(5),
18057      &  XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
18058
18059       INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
18060
18061       PARAMETER (IRMAX=200)
18062       DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
18063
18064       DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
18065      &                 DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
18066       INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
18067
18068 C  debug output
18069       IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18070      &  'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
18071      &  IMODE,IF,IL,PTCUT
18072
18073 C  give primordial kt to partons engaged in a hard scattering
18074
18075       IF(IMODE.EQ.1) THEN
18076
18077         ISTART = IF
18078
18079  100    CONTINUE
18080
18081         NHD = 0
18082         IBAL(1) = 0
18083         IBAL(2) = 0
18084         IROT = 0
18085         ICOM = 0
18086         DO 110 I=ISTART,IL
18087           IF(ISTHEP(I).EQ.25) THEN
18088 C  hard scattering number
18089             NHD = IPHIST(1,I+1)
18090             ICOM = I
18091             K = LSIDX(NHD/100)
18092 C  calculate momenta of incoming partons
18093             POLD(1,1) = XHD(K,1)*ECMP/2.D0
18094             POLD(2,1) = POLD(1,1)
18095             POLD(1,2) = -XHD(K,2)*ECMP/2.D0
18096             POLD(2,2) = -POLD(1,2)
18097             ISTART = I+3
18098             GOTO 150
18099           ENDIF
18100  110    CONTINUE
18101         RETURN
18102
18103  150    CONTINUE
18104
18105 C  search for partons involved in hard interaction
18106         INEXT = 0
18107         IROT = 0
18108         DO 500 I=ISTART,IL
18109           IF(ABS(ISTHEP(I)).EQ.1) THEN
18110 C  hard scatterd partons (including ISR)
18111             IF((IPHIST(1,I).EQ.-NHD)
18112      &         .OR.(IPHIST(1,I).EQ.NHD+1)
18113      &         .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
18114               IROT = IROT+1
18115
18116               IF(IROT.GT.IRMAX) THEN
18117                 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
18118      &            'no memory left in IROTT, event rejected (max/IROT)',
18119      &            IRMAX,IROT
18120                 CALL PHO_PREVNT(0)
18121                 IREJ = 1
18122                 RETURN
18123               ENDIF
18124
18125               IROTT(IROT) = I
18126 C  hard remnant
18127             ELSE IF(IPHIST(1,I).EQ.NHD) THEN
18128               IF(PHEP(3,I).GT.0.D0) THEN
18129                 J = 1
18130               ELSE
18131                 J = 2
18132               ENDIF
18133               IBAL(J) = IBAL(J)+1
18134               IBALT(IBAL(J),J) = I
18135               XP2(IBAL(J),J) = PHEP(3,I)/ECMP
18136               IF(ISWMDL(24).EQ.0) THEN
18137                 IV2(IBAL(J),J) = 0
18138                 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
18139               ELSE IF(ISWMDL(24).EQ.1) THEN
18140                 IV2(IBAL(J),J) = -1
18141               ELSE
18142                 IV2(IBAL(J),J) = 1
18143               ENDIF
18144             ENDIF
18145 C  possibly further hard scattering
18146           ELSE IF(ISTHEP(I).EQ.25) THEN
18147             INEXT = 1
18148             ISTART = I
18149             GOTO 550
18150           ENDIF
18151  500    CONTINUE
18152  550    CONTINUE
18153
18154 C debug output
18155         if(IDEB(10).ge.15) then
18156           WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
18157      &      'hard scattering number: ',NHD/100
18158           WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
18159      &      'number of entries to rotate: ',IROT
18160           DO I=1,IROT
18161             WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
18162      &        'entries to rotate: ',I,IROTT(I)
18163           ENDDO
18164           WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
18165      &      'number of entries to balance: ',IBAL
18166           DO J=1,2
18167             DO I=1,IBAL(J)
18168               WRITE(LO,'(1X,2A,I2,2I5)')
18169      &          'PHO_PRIMKT: entries to balance (side,no,line)',
18170      &          J,I,IBALT(I,J)
18171             ENDDO
18172           ENDDO
18173         endif
18174
18175 C  incoming partons (comment lines), skip direct interacting particles
18176         DO 120 K=1,2
18177           IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
18178             IF(PHEP(3,ICOM+K).GT.0.D0) THEN
18179               J = 1
18180             ELSE
18181               J = 2
18182             ENDIF
18183             IBAL(J) = IBAL(J)+1
18184             IBALT(IBAL(J),J) = -ICOM-K
18185             XP2(IBAL(J),J) = POLD(1,J)/ECMP
18186             IV2(IBAL(J),J) = -1
18187           ENDIF
18188  120    CONTINUE
18189
18190 C  check consistency
18191         IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18192           WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18193      &      'inconsistent hard scattering remnant for event: ',KEVENT
18194           WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18195      &      'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18196      &      IMODE,IF,IL,PTCUT
18197           WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18198           DO 390 I=1,IROT
18199             WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18200  390      CONTINUE
18201           DO 392 J=1,2
18202             DO 395 I=1,IBAL(J)
18203               WRITE(LO,'(1X,A,I2,2I5)')
18204      &          'entries to balance (side,no,line)',J,I,IBALT(I,J)
18205  395        CONTINUE
18206  392      CONTINUE
18207           IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18208         ENDIF
18209
18210 C  calculate primordial kt
18211
18212 C  something to do?
18213         IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18214
18215 C  add transverse momentum (overwrite /POEVT1/ entries)
18216         DO 200 J=1,2
18217           IF(IBAL(J).GT.1) THEN
18218 C  sample from truncated distribution
18219             K = IBAL(J)
18220             DO 180 I=1,K
18221               IV(I) = IV2(I,J)
18222               XP(I) = XP2(I,J)
18223  180        CONTINUE
18224  190        CONTINUE
18225               CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18226             IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18227 C  transform incoming partons of hard scattering
18228             DEL = ABS(POLD(1,J))+POLD(2,J)
18229             PT2 = PTS(0,K)**2
18230             DEL2 = DEL*DEL
18231             PNEW(1,J) = PTS(1,K)
18232             PNEW(2,J) = PTS(2,K)
18233             PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18234             PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18235 C  spectator partons
18236             ESUM = 0.D0
18237             DO 220 I=1,IBAL(J)-1
18238               K = IBALT(I,J)
18239               PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18240               PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18241               ESUM = ESUM+PHEP(4,K)
18242  220        CONTINUE
18243 C  long. momentum transfer
18244             PP(3) = PNEW(3,J) - POLD(1,J)
18245             PP(4) = PNEW(4,J) - POLD(2,J)
18246             DO 230 I=1,IBAL(J)-1
18247               K = IBALT(I,J)
18248               FAC = PHEP(4,K)/ESUM
18249               PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18250               PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18251  230        CONTINUE
18252
18253 C  debug output
18254             IF(IDEB(10).GE.15) THEN
18255               WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18256      &          'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18257               WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18258      &          'new incoming:',J,(PNEW(I,J),I=1,4)
18259             ENDIF
18260
18261           ELSE
18262             PNEW(1,J) = 0.D0
18263             PNEW(2,J) = 0.D0
18264             PNEW(3,J) = POLD(1,J)
18265             PNEW(4,J) = POLD(2,J)
18266           ENDIF
18267  200    CONTINUE
18268
18269 C  transformation of hard scattering final states (including ISR)
18270
18271 C  old parton c.m. energy
18272         SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18273         EI = SQRT(SI)
18274 C  new parton c.m. energy
18275         SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18276      &       -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18277         EF = SQRT(SF)
18278         FAC = EF/EI
18279 C  debug output
18280         IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18281      &    'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18282
18283 C  calculate Lorentz transformation
18284         GAZ = -(POLD(1,1)+POLD(1,2))/EI
18285         GAE = (POLD(2,1)+POLD(2,2))/EI
18286         DO 240 I=1,4
18287           GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18288  240    CONTINUE
18289         CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18290      &    PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18291         PTOT = MAX(DEPS,PTOT)
18292         COD= PP(3)/PTOT
18293         SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18294         COF= 1.D0
18295         SIF= 0.D0
18296         IF(PTOT*SID.GT.1.D-5) THEN
18297           COF=PP(1)/(SID*PTOT)
18298           SIF=PP(2)/(SID*PTOT)
18299           ANORF=SQRT(COF*COF+SIF*SIF)
18300           COF=COF/ANORF
18301           SIF=SIF/ANORF
18302         ENDIF
18303
18304 C  debug output
18305 C  check consistency initial/final configuration before rotation
18306         IF(IDEB(10).GE.25) THEN
18307           WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18308      &      0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18309           DO I=1,4
18310             PP(I) = 0.D0
18311           ENDDO
18312           DO I=1,IROT
18313             K = IROTT(I)
18314             DO J=1,4
18315               PP(J) = PP(J)+PHEP(J,K)
18316             ENDDO
18317           ENDDO
18318           WRITE(LO,'(1X,A,1P,4E11.3)')
18319      &      'PHO_PRIMKT: fin. momentum (1):',PP
18320         ENDIF
18321
18322 C  apply rotation/boost to scattered particles
18323         DO 400 I=1,IROT
18324           K = IROTT(I)
18325           DO 350 J=1,4
18326             PP(J) = FAC*PHEP(J,K)
18327  350      CONTINUE
18328           CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18329      &      PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18330           CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18331      &      COD,SID,COF,SIF,XX,YY,ZZ)
18332           EE = PHEP(4,K)
18333           CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18334      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18335  400    CONTINUE
18336
18337 C  debug output
18338 C  check consistency initial/final configuration after rotation
18339         IF(IDEB(10).GE.25) THEN
18340           DO I=1,4
18341             PP(I) = PNEW(I,1)+PNEW(I,2)
18342           ENDDO
18343           WRITE(LO,'(1X,A,1P,4E11.3)')
18344      &      'PHO_PRIMKT: ini. momentum (2):',PP
18345           DO I=1,4
18346             PP(I) = 0.D0
18347           ENDDO
18348           DO I=1,IROT
18349             K = IROTT(I)
18350             DO J=1,4
18351               PP(J) = PP(J)+PHEP(J,K)
18352             ENDDO
18353           ENDDO
18354           WRITE(LO,'(1X,A,1P,4E11.3)')
18355      &      'PHO_PRIMKT: fin. momentum (2):',PP
18356         ENDIF
18357
18358         ENDIF
18359
18360         IF(INEXT.EQ.1) GOTO 100
18361
18362 C  initialization
18363
18364       ELSE IF(IMODE.EQ.-1) THEN
18365
18366 C  output of statistics etc.
18367
18368       ELSE IF(IMODE.EQ.-2) THEN
18369
18370 C  something wrong
18371
18372       ELSE
18373         WRITE(LO,'(/1X,A,I4)')
18374      &    'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18375         CALL PHO_ABORT
18376       ENDIF
18377
18378       END
18379
18380 *$ CREATE PHO_PARTPT.FOR
18381 *COPY PHO_PARTPT
18382 CDECK  ID>, PHO_PARTPT
18383       SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18384 C********************************************************************
18385 C
18386 C    assign to soft partons
18387 C
18388 C    input:  IMODE   -2   output of statistics
18389 C                    -1   initialization
18390 C                     0   sampling of pt for soft partons belonging to
18391 C                         soft Pomerons
18392 C                     1   sampling of pt for soft partons belonging to
18393 C                         hard Pomerons
18394 C            IF           first entry in /POEVT1/ to check
18395 C            IL           last entry in /POEVT1/ to check
18396 C            PTCUT        current value of PTCUT to distinguish
18397 C                         between soft and hard
18398 C
18399 C    output: IREJ     0   success
18400 C                     1   failure
18401 C
18402 C    (soft pt is sampled by call to PHO_SOFTPT)
18403 C
18404 C********************************************************************
18405       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18406       SAVE
18407
18408       PARAMETER ( DEPS = 1.D-15 )
18409
18410       INTEGER IMODE,IF,IL,IREJ
18411       DOUBLE PRECISION PTCUT
18412
18413 C  input/output channels
18414       INTEGER LI,LO
18415       COMMON /POINOU/ LI,LO
18416 C  event debugging information
18417       INTEGER NMAXD
18418       PARAMETER (NMAXD=100)
18419       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18420      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18421       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18422      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18423 C  model switches and parameters
18424       CHARACTER*8 MDLNA
18425       INTEGER ISWMDL,IPAMDL
18426       DOUBLE PRECISION PARMDL
18427       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18428 C  some constants
18429       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18430       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18431      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18432 C  data of c.m. system of Pomeron / Reggeon exchange
18433       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18434       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18435      &                 SIDP,CODP,SIFP,COFP
18436       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18437      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18438      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18439
18440 C  standard particle data interface
18441       INTEGER NMXHEP
18442
18443       PARAMETER (NMXHEP=4000)
18444
18445       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18446       DOUBLE PRECISION PHEP,VHEP
18447       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18448      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18449      &                VHEP(4,NMXHEP)
18450 C  extension to standard particle data interface (PHOJET specific)
18451       INTEGER IMPART,IPHIST,ICOLOR
18452       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18453
18454       DOUBLE PRECISION PTS,PB,XP,XPB,PC
18455       DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18456
18457       INTEGER MODIFY,IV,IVB
18458       DIMENSION MODIFY(50),IV(50),IVB(2)
18459
18460 C  debug output
18461       IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18462      &  'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18463      &  IMODE,IF,IL,PTCUT
18464
18465       IF(IMODE.LT.0) GOTO 1000
18466
18467       IREJ = 0
18468       IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18469
18470 C  count entries to modify
18471       IENTRY = 0
18472       PTCUT2 = PTCUT**2
18473       EMIN = 1.D20
18474       IPEAK = 1
18475       ISTART = IF
18476
18477 C  soft Pomerons
18478
18479       IF(IMODE.EQ.0) THEN
18480         DO 300 I=ISTART,IL
18481           IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18482             IENTRY = IENTRY+1
18483             MODIFY(IENTRY) = I
18484             XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18485             IV(IENTRY) = 0
18486             IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18487             IF(PHEP(4,I).LT.EMIN) THEN
18488               EMIN = PHEP(4,I)
18489               IPEAK = IENTRY
18490             ENDIF
18491           ENDIF
18492  300    CONTINUE
18493
18494 C  hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18495
18496       ELSE IF(IMODE.EQ.1) THEN
18497
18498         DO 350 I=ISTART,IL
18499           IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18500             IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18501               IENTRY = IENTRY+1
18502               MODIFY(IENTRY) = I
18503               XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18504               IF(ISWMDL(24).EQ.0) THEN
18505                 IV(IENTRY) = 0
18506                 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18507               ELSE IF(ISWMDL(24).EQ.1) THEN
18508                 IV(IENTRY) = -1
18509               ELSE
18510                 IV(IENTRY) = 1
18511               ENDIF
18512               IF(PHEP(4,I).LT.EMIN) THEN
18513                 EMIN = PHEP(4,I)
18514                 IPEAK = IENTRY
18515               ENDIF
18516             ENDIF
18517           ENDIF
18518  350    CONTINUE
18519
18520 C  something wrong
18521
18522       ELSE
18523         WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18524         CALL PHO_ABORT
18525       ENDIF
18526
18527 C  debug output
18528       IF(IDEB(6).GE.5) THEN
18529         WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18530      &    'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18531         IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18532       ENDIF
18533
18534 C  nothing to do
18535       IF(IENTRY.LE.1) RETURN
18536
18537 C  sample pt of soft partons
18538
18539       IF(ISWMDL(5).LE.1) THEN
18540         ITER = 0
18541         IPEAK = DT_RNDM(DUM)*IENTRY+1
18542         CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18543         CALL PHO_SWAPD(XP(IPEAK),XP(1))
18544         CALL PHO_SWAPI(IV(IPEAK),IV(1))
18545  400    CONTINUE
18546 C  energy limited sampling
18547           PSUMX = 0.D0
18548           PSUMY = 0.D0
18549           ITER = ITER+1
18550           IF(ITER.GE.1000) THEN
18551             IF(IDEB(6).GE.3) THEN
18552               WRITE(LO,'(1X,A,3I5)')
18553      &          'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18554      &          IMODE,IENTRY,ITER
18555               WRITE(LO,'(8X,A,I5)') 'I  II  IV       XP         EP',
18556      &          IPEAK
18557               DO 405 I=1,IENTRY
18558                 II = MODIFY(I)
18559                 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18560      &            I,II,IV(I),XP(I),PHEP(4,II)
18561  405          CONTINUE
18562               IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18563             ENDIF
18564             IREJ = 1
18565             RETURN
18566           ENDIF
18567           DO 410 I=2,IENTRY
18568             II = MODIFY(I)
18569             PTMX = MIN(PHEP(4,II),PTCUT)
18570             XPB(1) = XP(I)
18571             IVB(1) = IV(I)
18572             IF(ISWMDL(5).EQ.0) THEN
18573               CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18574             ELSE
18575               CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18576             ENDIF
18577             PTS(0,I) = PB(0,1)
18578             PTS(1,I) = PB(1,1)
18579             PTS(2,I) = PB(2,1)
18580             PSUMX = PSUMX+PB(1,1)
18581             PSUMY = PSUMY+PB(2,1)
18582  410      CONTINUE
18583           PTREM = SQRT(PSUMX**2+PSUMY**2)
18584         IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18585         PTS(1,1) = -PSUMX
18586         PTS(2,1) = -PSUMY
18587       ELSE IF((ISWMDL(5).EQ.2)
18588      &        .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18589 C  unlimited sampling
18590         IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18591         CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18592         CALL PHO_SWAPD(XP(IPEAK),XP(1))
18593         CALL PHO_SWAPI(IV(IPEAK),IV(1))
18594         CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18595       ELSE IF(ISWMDL(5).EQ.3) THEN
18596 C  each string has balanced pt
18597         DO 500 K=1,IENTRY
18598           IF(IV(K).LE.-90) GOTO 499
18599           I1 = MODIFY(K)
18600           IC1 = -ICOLOR(1,I1)
18601           DO 510 L=K+1,IENTRY
18602             IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18603  510      CONTINUE
18604           WRITE(LO,'(//1X,A,I5)')
18605      &      'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18606           CALL PHO_ABORT
18607  511      CONTINUE
18608           I2 = MODIFY(L)
18609           AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18610      &           -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18611           AM   = SQRT(AMSQR)
18612           PTMX = AM/2.D0
18613           IVB(1) = MAX(IV(K),IV(L))
18614           XPB(1) = XP(K)
18615           CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18616           PTS(1,K) = PB(1,1)
18617           PTS(2,K) = PB(2,1)
18618           PTS(1,L) = -PB(1,1)
18619           PTS(2,L) = -PB(2,1)
18620           GAM    = (PHEP(4,I1)+PHEP(4,I2))/AM
18621           GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18622           PC(1) = PB(1,1)
18623           PC(2) = PB(2,1)
18624           PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18625           PC(3) = SIGN(PLONG,PHEP(3,I1))
18626           PC(4) = PTMX
18627           CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18628      &               PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18629           PC(1) = -PC(1)
18630           PC(2) = -PC(2)
18631           PC(3) = -PC(3)
18632           CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18633      &               PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18634           IV(K) = IV(K)-100
18635           IV(L) = IV(L)-100
18636  499      CONTINUE
18637  500    CONTINUE
18638       ELSE
18639         WRITE(LO,'(/1X,A,I4)')
18640      &    'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18641         CALL PHO_ABORT
18642       ENDIF
18643
18644 C  change partons in /POEVT1/
18645       DO 900 II=1,IENTRY
18646         IF(IV(II).GT.-90) THEN
18647           I = MODIFY(II)
18648           PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18649           PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18650           AMSQR = PHEP(4,I)**2
18651      &             -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18652           PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18653         ENDIF
18654  900  CONTINUE
18655
18656 C  debug output
18657       IF(IDEB(6).GE.15) THEN
18658         WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18659      &    'I  II  IV    XP    EP    PTS   PTX   PTY',IPEAK
18660         DO 505 I=1,IENTRY
18661           II = MODIFY(I)
18662           WRITE(LO,'(2X,3I5,1P,5E12.4)')
18663      &      I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18664  505    CONTINUE
18665         CALL PHO_PREVNT(0)
18666       ENDIF
18667       RETURN
18668
18669 C  initialization / output of statistics
18670  1000 CONTINUE
18671       CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18672
18673       END
18674
18675 *$ CREATE PHO_SOFTPT.FOR
18676 *COPY PHO_SOFTPT
18677 CDECK  ID>, PHO_SOFTPT
18678       SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18679 C***********************************************************************
18680 C
18681 C    select pt of soft string ends
18682 C
18683 C    input:    ISOFT          number of soft partons
18684 C                    -1       initialization
18685 C                    >=0      sampling of p_t
18686 C                    -2       output of statistics
18687 C              PTCUT          cutoff for soft strings
18688 C              PTMAX          maximal allowed PT
18689 C              XV             field of x values
18690 C              IV             0    sea quark
18691 C                             1    valence quark
18692 C
18693 C    output:   /POINT3/       containing parameters AAS,BETAS
18694 C              PTSOF          filed with soft pt values
18695 C
18696 C    note:     ISWMDL(3/4) = 0  dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18697 C              ISWMDL(3/4) = 1  dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18698 C              ISWMDL(3/4) = 2  photon wave function
18699 C              ISWMDL(3/4) = 10 no soft P_t assignment
18700 C
18701 C***********************************************************************
18702       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18703       SAVE
18704
18705       PARAMETER ( DEPS   =  1.D-15)
18706
18707       DIMENSION PTSOF(0:2,*),XV(*)
18708       DIMENSION IV(*)
18709
18710 C  input/output channels
18711       INTEGER LI,LO
18712       COMMON /POINOU/ LI,LO
18713 C  event debugging information
18714       INTEGER NMAXD
18715       PARAMETER (NMAXD=100)
18716       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18717      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18718       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18719      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18720 C  model switches and parameters
18721       CHARACTER*8 MDLNA
18722       INTEGER ISWMDL,IPAMDL
18723       DOUBLE PRECISION PARMDL
18724       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18725 C  data of c.m. system of Pomeron / Reggeon exchange
18726       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18727       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18728      &                 SIDP,CODP,SIFP,COFP
18729       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18730      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18731      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18732 C  data on most recent hard scattering
18733       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18734       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18735      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18736      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18737       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18738      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18739      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18740      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18741      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18742 C  data needed for soft-pt calculation
18743       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18744       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18745
18746       DIMENSION BETAB(100)
18747
18748 C  selection of pt
18749       IF(ISOFT.GE.0) THEN
18750         CALLS = CALLS + 1.D0
18751 C  sample according to model ISWMDL(3-6)
18752         IF(ISOFT.GT.1) THEN
18753  210      CONTINUE
18754           PTXS = 0.D0
18755           PTYS = 0.D0
18756           DO 300 I=2,ISOFT
18757             IMODE = ISWMDL(3)
18758 C  valence partons
18759             IF(IV(I).EQ.1) THEN
18760               BETA = BETAS(1)
18761 C  photon/pomeron valence part
18762               IF(IPAMDL(5).EQ.1) THEN
18763                 IF(XV(I).GE.0.D0) THEN
18764                   IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18765                     IMODE = ISWMDL(4)
18766                     BETA = BETAS(3)
18767                   ENDIF
18768                 ELSE
18769                   IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18770                     IMODE = ISWMDL(4)
18771                     BETA = BETAS(3)
18772                   ENDIF
18773                 ENDIF
18774               ELSE IF(IPAMDL(5).EQ.2) THEN
18775                 BETA = PARMDL(20)
18776               ELSE IF(IPAMDL(5).EQ.3) THEN
18777                 BETA = BETAS(3)
18778               ENDIF
18779 C  sea partons
18780             ELSE IF(IV(I).EQ.0) THEN
18781               BETA = BETAS(3)
18782 C  hard scattering remnant
18783             ELSE
18784               IF(IPAMDL(6).EQ.0) THEN
18785                 BETA = BETAS(1)
18786               ELSE IF(IPAMDL(6).EQ.1) THEN
18787                 BETA = BETAS(3)
18788               ELSE
18789                 BETA = PARMDL(20)
18790               ENDIF
18791             ENDIF
18792             BETA = MAX(BETA,0.01D0)
18793             CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18794             PTS = MIN(PTMAX,PTS)
18795             CALL PHO_SFECFE(SIG,COG)
18796             PTSOF(0,I) = PTS
18797             PTSOF(1,I) = COG*PTS
18798             PTSOF(2,I) = SIG*PTS
18799             PTXS = PTXS+PTSOF(1,I)
18800             PTYS = PTYS+PTSOF(2,I)
18801             BETAB(I) = BETA
18802  300      CONTINUE
18803 C  balancing of momenta
18804           PTS = SQRT(PTXS**2+PTYS**2)
18805           IF(PTS.GE.PTMAX) GOTO 210
18806           PTSOF(0,1) = PTS
18807           PTSOF(1,1) = -PTXS
18808           PTSOF(2,1) = -PTYS
18809           BETAB(1) = 0.D0
18810 C
18811 *400      CONTINUE
18812 C
18813 C  single parton only
18814         ELSE
18815           IMODE = ISWMDL(3)
18816 C  valence partons
18817           IF(IV(1).EQ.1) THEN
18818             BETA = BETAS(1)
18819 C  photon/Pomeron valence part
18820             IF(IPAMDL(5).EQ.1) THEN
18821               IF(XV(1).GE.0.D0) THEN
18822                 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18823                   IMODE = ISWMDL(4)
18824                   BETA = BETAS(3)
18825                 ENDIF
18826               ELSE
18827                 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18828                   IMODE = ISWMDL(4)
18829                   BETA = BETAS(3)
18830                 ENDIF
18831               ENDIF
18832             ELSE IF(IPAMDL(5).EQ.2) THEN
18833               BETA = PARMDL(20)
18834             ELSE IF(IPAMDL(5).EQ.3) THEN
18835               BETA = BETAS(3)
18836             ENDIF
18837 C  sea partons
18838           ELSE IF(IV(1).EQ.0) THEN
18839             BETA = BETAS(3)
18840 C  hard scattering remnant
18841           ELSE
18842             IF(IPAMDL(6).EQ.1) THEN
18843               BETA = BETAS(3)
18844             ELSE
18845               BETA = PARMDL(20)
18846             ENDIF
18847           ENDIF
18848           BETA = MAX(BETA,0.01D0)
18849           CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18850           PTS = MIN(PTMAX,PTS)
18851           CALL PHO_SFECFE(SIG,COG)
18852           PTSOF(0,1) = PTS
18853           PTSOF(1,1) = COG*PTS
18854           PTSOF(2,1) = SIG*PTS
18855           BETAB(1) = BETA
18856         ENDIF
18857
18858 C  debug output
18859         IF(IDEB(29).GE.10) THEN
18860           WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18861           WRITE(LO,'(6X,A)') 'TABLE OF  I, IV, XV, PT, PT-X, PT-Y, BETA'
18862           DO 105 I=1,ISOFT
18863             WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18864      &        PTSOF(1,I),PTSOF(2,I),BETAB(I)
18865  105      CONTINUE
18866         ENDIF
18867
18868 C  initialization of statistics and parameters
18869
18870       ELSE IF(ISOFT.EQ.-1) THEN
18871         PTSMIN = 0.D0
18872         PTSMAX = PTCUT
18873
18874         IMODE = -100+ISWMDL(3)
18875         CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18876
18877 C  output of statistics
18878
18879       ELSE IF(ISOFT.EQ.-2) THEN
18880
18881       ELSE
18882         WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18883      &    'unsupported ISOFT ',ISOFT
18884         STOP
18885       ENDIF
18886       END
18887
18888 *$ CREATE PHO_SELPT.FOR
18889 *COPY PHO_SELPT
18890 CDECK  ID>, PHO_SELPT
18891       SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18892 C***********************************************************************
18893 C
18894 C    select pt from different distributions
18895 C
18896 C    input:    EE            energy (for initialization only)
18897 C                            otherwise x value of corresponding parton
18898 C              PTLOW         lower pt limit
18899 C              PTHIGH        upper pt limit
18900 C                            (PTHIGH > 20 will cause DEXP underflows)
18901 C
18902 C              IMODE = 0     dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18903 C              IMODE = 1     dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18904 C              IMODE = 2     dNs/dP_t according photon wave function
18905 C              IMODE = 10    no sampling
18906 C
18907 C              IMODE = -100+IMODE    initialization according to
18908 C                                    given limitations
18909 C
18910 C    output:   PTS           sampled pt value
18911 C    initialization:
18912 C              BETA          soft pt slope in central region
18913 C
18914 C***********************************************************************
18915       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18916       SAVE
18917
18918       PARAMETER ( PI2    =  6.28318530718D0,
18919      &            AMIN   =  1.D-2,
18920      &            EPS    =  1.D-7,
18921      &            DEPS   =  1.D-30)
18922
18923 C  input/output channels
18924       INTEGER LI,LO
18925       COMMON /POINOU/ LI,LO
18926 C  event debugging information
18927       INTEGER NMAXD
18928       PARAMETER (NMAXD=100)
18929       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18930      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18931       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18932      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18933 C  model switches and parameters
18934       CHARACTER*8 MDLNA
18935       INTEGER ISWMDL,IPAMDL
18936       DOUBLE PRECISION PARMDL
18937       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18938 C  data of c.m. system of Pomeron / Reggeon exchange
18939       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18940       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18941      &                 SIDP,CODP,SIFP,COFP
18942       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18943      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18944      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18945 C  average number of cut soft and hard ladders (obsolete)
18946       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18947       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18948 C  data needed for soft-pt calculation
18949       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18950       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18951
18952       DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18953       EXTERNAL PHO_CONN0,PHO_CONN1
18954
18955 C  initialization
18956
18957       IF(IMODE.LT.0) GOTO 100
18958
18959       PX = PTHIGH
18960       PTS = 0.D0
18961
18962 C  initial checks
18963
18964       IF(PX.LT.AMIN) RETURN
18965
18966       IF((PX-PTLOW).LT.0.01) THEN
18967         IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18968      &    'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18969         RETURN
18970       ENDIF
18971
18972 C  sampling of pt values according to IMODE
18973
18974       IF(IMODE.EQ.0) THEN
18975
18976         FAC1 = EXP(-BETA*PX**2)
18977         FAC2 = (1.D0-FAC1)
18978  25     CONTINUE
18979           XI1 = DT_RNDM(PX)*FAC2 + FAC1
18980           PTS = SQRT(-1.D0/BETA*LOG(XI1))
18981         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18982
18983       ELSE IF(IMODE.EQ.1) THEN
18984
18985         XIMIN = EXP(-BETA*PTHIGH)
18986         XIDEL = 1.D0-XIMIN
18987  50     CONTINUE
18988           PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18989      &              *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18990         IF(PTS.LT.XMT) GOTO 50
18991         PTS = SQRT(PTS**2-XMT2)
18992         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18993
18994       ELSE IF(IMODE.EQ.2) THEN
18995
18996         IF(EE.GE.0.D0) THEN
18997           P2 = PVIRTP(1)
18998         ELSE
18999           P2 = PVIRTP(2)
19000         ENDIF
19001         XV = ABS(EE)
19002         AA = (1.D0-XV)*XV*P2+PARMDL(25)
19003  75     CONTINUE
19004           PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
19005         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
19006
19007 C  something wrong
19008
19009       ELSE IF(IMODE.NE.10) THEN
19010         WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
19011         CALL PHO_ABORT
19012       ENDIF
19013
19014 C  debug output
19015       IF(IDEB(5).GE.20) THEN
19016         WRITE(LO,'(1X,A,I3,4E10.3)')
19017      &    'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
19018      &    IMODE,BETA,PTLOW,PTHIGH,PTS
19019       ENDIF
19020       RETURN
19021
19022 C  initialization
19023  100  CONTINUE
19024         PTSMIN = PTLOW
19025         PTSMAX = PTHIGH
19026         PTCON = PTHIGH
19027 C  calculation of parameters
19028         INIT = IMODE+100
19029         AAS = 0.D0
19030
19031 C  initialization for model 0 (gaussian pt distribution)
19032
19033         IF(INIT.EQ.0) THEN
19034           BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
19035           BETUP = BETAS(1)
19036           BETLO = -2.D0
19037           XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
19038           IF(XTOL.LT.0.D0) THEN
19039             XTOL = 1.D-4
19040             METHOD = 1
19041             MAXF = 500
19042             BETA = 0.D0
19043             BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
19044 *           IF(BETA.LT.-1.D+10) THEN
19045 *             WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
19046 *    &          '(model 0: Ecm,PTcut)',EE,PTCON
19047 *             WRITE(LO,'(1X,A,1P,3E10.3)')
19048 *    &          'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
19049 *             CALL PHO_PREVNT(-1)
19050 *             BETA = 0.01
19051 *           ELSE
19052               AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
19053 *           ENDIF
19054           ELSE
19055             AAS = 0.D0
19056             BETA = BETAS(1)
19057           ENDIF
19058
19059 C  initialization for model 1 (exponential pt distribution)
19060
19061         ELSE IF(INIT.EQ.1) THEN
19062           XMT = PARMDL(43)
19063           XMT2 = XMT*XMT
19064           BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
19065           BETUP = BETAS(1)
19066           BETLO = -3.D0
19067           XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
19068           IF(XTOL.LT.0.D0) THEN
19069             XTOL = 1.D-4
19070             METHOD = 1
19071             MAXF = 500
19072             BETA = 0.D0
19073             BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
19074 *           IF(BETA.LT.-1.D+10) THEN
19075 *             WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
19076 *    &          '(model 1: Ecm,PTcut)',EE,PTCON
19077 *             WRITE(LO,'(1X,A,1P,3E10.3)')
19078 *    &          'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
19079 *             CALL PHO_PREVNT(-1)
19080 *             BETA = 0.01
19081 *           ELSE
19082               AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
19083 *           ENDIF
19084           ELSE
19085             AAS = 0.D0
19086             BETA = BETAS(1)
19087           ENDIF
19088         ELSE IF(INIT.EQ.10) THEN
19089           IF(IDEB(5).GT.10)
19090      &      WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
19091           RETURN
19092         ELSE
19093           WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
19094      &      INIT
19095           CALL PHO_ABORT
19096         ENDIF
19097         BETA = MIN(BETA,BETAS(1))
19098
19099 C  hard cross section is too big: neg. beta parameter
19100         IF(BETA.LE.0.D0) THEN
19101           WRITE(LO,'(1X,A,1P,2E12.3)')
19102      &      'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
19103           WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
19104      &      SIGS,DSIGHP,SIGH,PTCON
19105           CALL PHO_PREVNT(-1)
19106         ENDIF
19107
19108 C  output of initialization parameters
19109         IF(IDEB(5).GE.10) THEN
19110           WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
19111      &      INIT
19112           WRITE(LO,'(5X,A,1P,2E13.3)')
19113      &      'BETA,AAS        ',BETA,AAS
19114           WRITE(LO,'(5X,A,1P,3E13.3)')
19115      &      'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
19116           WRITE(LO,'(5X,A,1P,3E13.3)')
19117      &      'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
19118         ENDIF
19119
19120       END
19121
19122 *$ CREATE PHO_CONN0.FOR
19123 *COPY PHO_CONN0
19124 CDECK  ID>, PHO_CONN0
19125       DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
19126 C***********************************************************************
19127 C
19128 C    auxiliary function to determine parameters of soft
19129 C    pt distribution  dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
19130 C
19131 C    internal factors: FS  number of soft partons in soft Pomeron
19132 C                      FH  number of soft partons in hard Pomeron
19133 C
19134 C***********************************************************************
19135
19136       IMPLICIT NONE
19137
19138       SAVE
19139
19140 C  input/output channels
19141       INTEGER LI,LO
19142       COMMON /POINOU/ LI,LO
19143 C  average number of cut soft and hard ladders (obsolete)
19144       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19145       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19146 C  data needed for soft-pt calculation
19147       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19148       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19149
19150       DOUBLE PRECISION BETA,XX,FF
19151
19152       XX = BETA*PTCON**2
19153       IF(ABS(XX).LT.1.D-3) THEN
19154         FF = FS*SIGS+FH*SIGH
19155      &       - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
19156       ELSE
19157         FF = FS*SIGS+FH*SIGH
19158      &       - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
19159       ENDIF
19160       PHO_CONN0 = FF
19161
19162 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
19163 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19164
19165       END
19166
19167 *$ CREATE PHO_CONN1.FOR
19168 *COPY PHO_CONN1
19169 CDECK  ID>, PHO_CONN1
19170       DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
19171 C***********************************************************************
19172 C
19173 C    auxiliary function to determine parameters of soft
19174 C    pt distribution  dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
19175 C
19176 C    internal factors: FS  number of soft partons in soft Pomeron
19177 C                      FH  number of soft partons in hard Pomeron
19178 C
19179 C***********************************************************************
19180
19181       IMPLICIT NONE
19182
19183       SAVE
19184
19185 C  input/output channels
19186       INTEGER LI,LO
19187       COMMON /POINOU/ LI,LO
19188 C  average number of cut soft and hard ladders (obsolete)
19189       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19190       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19191 C  data needed for soft-pt calculation
19192       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19193       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19194
19195       DOUBLE PRECISION BETA,XX,FF
19196
19197       XX = BETA*PTCON
19198       IF(ABS(XX).LT.1.D-3) THEN
19199         FF = FS*SIGS+FH*SIGH
19200      &       - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
19201       ELSE
19202         FF = FS*SIGS+FH*SIGH
19203      &       - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19204       ENDIF
19205       PHO_CONN1 = FF
19206
19207 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19208 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19209
19210       END
19211
19212 *$ CREATE PHO_MSHELL.FOR
19213 *COPY PHO_MSHELL
19214 CDECK  ID>, PHO_MSHELL
19215       SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19216 C********************************************************************
19217 C
19218 C    rescaling of momenta of two partons to put both
19219 C                                       on mass shell
19220 C
19221 C    input:       PA1,PA2   input momentum vectors
19222 C                 XM1,2     desired masses of particles afterwards
19223 C                 P1,P2     changed momentum vectors
19224 C
19225 C********************************************************************
19226       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19227       SAVE
19228
19229       PARAMETER ( DEPS   =  1.D-20 )
19230
19231       DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19232
19233 C  input/output channels
19234       INTEGER LI,LO
19235       COMMON /POINOU/ LI,LO
19236 C  event debugging information
19237       INTEGER NMAXD
19238       PARAMETER (NMAXD=100)
19239       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19240      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19241       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19242      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19243 C  internal rejection counters
19244       INTEGER NMXJ
19245       PARAMETER (NMXJ=60)
19246       CHARACTER*10 REJTIT
19247       INTEGER IFAIL
19248       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19249
19250       IREJ = 0
19251       IDEV = 0
19252 C  debug output
19253       IF(IDEB(40).GE.10) THEN
19254         WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19255         WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19256         WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19257         WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19258       ENDIF
19259
19260 C  Lorentz transformation into system CMS
19261       PX = PA1(1)+PA2(1)
19262       PY = PA1(2)+PA2(2)
19263       PZ = PA1(3)+PA2(3)
19264       EE = PA1(4)+PA2(4)
19265       XMS = EE**2-PX**2-PY**2-PZ**2
19266       IF(XMS.LT.(XM1+XM2)**2) THEN
19267         IREJ = 1
19268         IFAIL(37) = IFAIL(37)+1
19269
19270         if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19271
19272         IF(IDEB(40).GE.3) THEN
19273           WRITE(LO,'(/1X,A,I12)')
19274      &      'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19275           WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19276      &      SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19277           WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19278           IDEV = 5
19279           IF(IDEB(40).GE.3) GOTO 55
19280         ENDIF
19281         RETURN
19282       ENDIF
19283       XMS = SQRT(XMS)
19284       BGX = PX/XMS
19285       BGY = PY/XMS
19286       BGZ = PZ/XMS
19287       GAM = EE/XMS
19288       CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19289      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19290 C  rotation angles
19291       PTOT1 = MAX(DEPS,PTOT1)
19292       COD = P1(3)/PTOT1
19293       SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19294       COF = 1.D0
19295       SIF = 0.D0
19296       IF(PTOT1*SID.GT.1.D-5) THEN
19297         COF = P1(1)/(SID*PTOT1)
19298         SIF = P1(2)/(SID*PTOT1)
19299         ANORF = SQRT(COF*COF+SIF*SIF)
19300         COF = COF/ANORF
19301         SIF = SIF/ANORF
19302       ENDIF
19303
19304 C  new CM momentum and energies (for masses XM1,XM2)
19305       XM12 = XM1**2
19306       XM22 = XM2**2
19307       SS   = XMS**2
19308       PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19309       EE1  = SQRT(XM12+PCMP**2)
19310       EE2  = XMS-EE1
19311 C  back rotation
19312       CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19313       CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19314      &           PTOT1,P1(1),P1(2),P1(3),P1(4))
19315       CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19316      &           PTOT2,P2(1),P2(2),P2(3),P2(4))
19317
19318 C  check consistency
19319       DEL = XMS*0.0001
19320       IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19321         IDEV = 1
19322       ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19323         IDEV = 2
19324       ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19325         IDEV = 3
19326       ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19327         IDEV = 4
19328       ENDIF
19329  55   CONTINUE
19330 C  debug output
19331       IF(IDEV.NE.0) THEN
19332         WRITE(LO,'(1X,A,I3)')
19333      &    'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19334         WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19335         WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19336         WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19337         WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19338         WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19339         WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19340         WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19341       ELSE IF(IDEB(40).GE.10) THEN
19342         WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19343         WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19344         WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19345       ENDIF
19346       END
19347
19348 *$ CREATE PHO_GLU2QU.FOR
19349 *COPY PHO_GLU2QU
19350 CDECK  ID>, PHO_GLU2QU
19351       SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19352 C********************************************************************
19353 C
19354 C    split gluon with index I in POEVT1
19355 C          (massless gluon assumed)
19356 C
19357 C    input:      /POEVT1/
19358 C                IG      gluon index
19359 C                IQ1     first quark index
19360 C                IQ2     second quark index
19361 C
19362 C    output:     new quarks in /POEVT1/
19363 C                IREJ    1 splitting impossible
19364 C                        0 splitting successful
19365 C
19366 C********************************************************************
19367       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19368       SAVE
19369
19370       PARAMETER ( DEPS   =  1.D-15,
19371      &            EPS    =  1.D-5 )
19372
19373 C  input/output channels
19374       INTEGER LI,LO
19375       COMMON /POINOU/ LI,LO
19376 C  event debugging information
19377       INTEGER NMAXD
19378       PARAMETER (NMAXD=100)
19379       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19380      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19381       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19382      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19383 C  model switches and parameters
19384       CHARACTER*8 MDLNA
19385       INTEGER ISWMDL,IPAMDL
19386       DOUBLE PRECISION PARMDL
19387       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19388
19389 C  standard particle data interface
19390       INTEGER NMXHEP
19391
19392       PARAMETER (NMXHEP=4000)
19393
19394       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19395       DOUBLE PRECISION PHEP,VHEP
19396       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19397      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19398      &                VHEP(4,NMXHEP)
19399 C  extension to standard particle data interface (PHOJET specific)
19400       INTEGER IMPART,IPHIST,ICOLOR
19401       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19402
19403 C  internal rejection counters
19404       INTEGER NMXJ
19405       PARAMETER (NMXJ=60)
19406       CHARACTER*10 REJTIT
19407       INTEGER IFAIL
19408       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19409
19410       DIMENSION P1(4),P2(4)
19411       DATA CUTM  /0.02D0/
19412
19413       IREJ = 0
19414
19415 C  calculate string masses max possible
19416       IF(ISWMDL(9).EQ.1) THEN
19417         CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19418      &     -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19419         IF(CMASS1.LT.CUTM) THEN
19420           IF(IDEB(73).GE.5) THEN
19421             WRITE(LO,'(1X,A,3I4,4E10.3)')
19422      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19423           ENDIF
19424           IFAIL(33) = IFAIL(33) + 1
19425           IREJ = 1
19426           RETURN
19427         ENDIF
19428         CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19429      &     -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19430         IF(CMASS2.LT.CUTM) THEN
19431           IF(IDEB(73).GE.5) THEN
19432             WRITE(LO,'(1X,A,3I4,4E10.3)')
19433      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19434           ENDIF
19435           IFAIL(33) = IFAIL(33) + 1
19436           IREJ = 1
19437           RETURN
19438         ENDIF
19439 C
19440 C  calculate minimal z
19441         ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19442         ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19443         ZMIN = MIN(ZMIN1,ZMIN2)
19444         IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19445           IF(IDEB(73).GE.5) THEN
19446             WRITE(LO,'(1X,A,3I3,4E10.3)')
19447      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19448      &        IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19449           ENDIF
19450           IFAIL(33) = IFAIL(33) + 1
19451           IREJ = 1
19452           RETURN
19453         ENDIF
19454       ELSE
19455         ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19456       ENDIF
19457 C
19458       ZFRAC = PHO_GLUSPL(ZMIN)
19459       IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19460         ZFRAC = 1.D0-ZFRAC
19461       ENDIF
19462       DO 200 I=1,4
19463         P1(I) = PHEP(I,IG)*ZFRAC
19464         P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19465  200  CONTINUE
19466 C  quark flavours
19467       CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19468       CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19469      &              +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19470       CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19471
19472       IF(ABS(IDHEP(IQ1)).GT.6) THEN
19473         K = SIGN(ABS(K),IDHEP(IQ1))
19474       ELSE
19475         K = -SIGN(ABS(K),IDHEP(IQ1))
19476       ENDIF
19477 C  colors
19478       IF(K.GT.0) THEN
19479         IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19480         IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19481       ELSE
19482         IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19483         IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19484       ENDIF
19485 C  register new partons
19486       CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19487      &            IPHIST(1,IG),0,IC1,0,IPOS,1)
19488       CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19489      &            IPHIST(1,IG),0,IC2,0,IPOS,1)
19490 C  debug output
19491       IF(IDEB(73).GE.20) THEN
19492           WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19493      &      'PHO_GLU2QU:','   IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19494      &      IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19495         WRITE(LO,'(1X,A,4I5)') '   flavours, colors  ',
19496      &    K,-K,IC1,IC2
19497       ENDIF
19498       END
19499
19500 *$ CREATE PHO_GLUSPL.FOR
19501 *COPY PHO_GLUSPL
19502 CDECK  ID>, PHO_GLUSPL
19503       DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19504 C*********************************************************************
19505 C
19506 C     calculate quark - antiquark light cone momentum fractions
19507 C     according to Altarelli-Parisi g->q aq splitting function
19508 C     (symmetric z interval assumed)
19509 C
19510 C     input: ZMIN    minimal Z value allowed,
19511 C                    1-ZMIN maximal Z value allowed
19512 C
19513 C********************************************************************
19514       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19515       SAVE
19516
19517       PARAMETER ( ALEXP= 0.3333333333D0,
19518      &            DEPS = 1.D-10 )
19519
19520 C  input/output channels
19521       INTEGER LI,LO
19522       COMMON /POINOU/ LI,LO
19523 C  event debugging information
19524       INTEGER NMAXD
19525       PARAMETER (NMAXD=100)
19526       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19527      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19528       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19529      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19530
19531       IF(ZMIN.GE.0.5D0) THEN
19532         IF(IDEB(69).GT.2) THEN
19533           WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19534         ENDIF
19535         ZZ=0.D0
19536         GOTO 1000
19537       ELSE IF(ZMIN.LE.0.D0) THEN
19538         IF(IDEB(69).GT.2) THEN
19539           WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19540         ENDIF
19541         ZMINL = DEPS
19542       ELSE
19543         ZMINL = ZMIN
19544       ENDIF
19545
19546       ZMAX = 1.D0-ZMINL
19547       XI   = DT_RNDM(ZMAX)
19548       ZZ   = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19549       IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19550
19551  1000 CONTINUE
19552       IF(IDEB(69).GE.10) THEN
19553         WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19554       ENDIF
19555       PHO_GLUSPL = ZZ
19556       END
19557
19558 *$ CREATE PHO_STDPAR.FOR
19559 *COPY PHO_STDPAR
19560 CDECK  ID>, PHO_STDPAR
19561       SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19562 C***********************************************************************
19563 C
19564 C     select the initial parton x-fractions and flavors and
19565 C     the final parton momenta and flavours
19566 C     for standard Pomeron/Reggeon cuts
19567 C
19568 C     input:   IJM1   index of mother particle 1 in /POEVT1/
19569 C              IJM2   index of mother particle 2 in /POEVT1/
19570 C              IGEN   production process of mother particles
19571 C              MSPOM  soft cut Pomerons
19572 C              MHPOM  hard or semihard cut Pomerons
19573 C              MSREG  soft cut Reggeons
19574 C              MHDIR  direct hard processes
19575 C
19576 C              IJM1   -1    initialization of statistics
19577 C                     -2    output of statistics
19578 C
19579 C     output:  partons are directly written to /POEVT1/,/POEVT2/
19580 C
19581 C          structure of /POSOFT/
19582 C               XS1(I),XS2(I):     x-values of initial partons
19583 C               IJSI1(I),IJSI2(I): flavor of initial parton
19584 C                                  0            gluon
19585 C                                  1,2,3,4      quarks
19586 C                                  negative     antiquarks
19587 C               IJSF1(I),IJSF2(I): flavor of final state partons
19588 C               PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19589 C                                J=1   PX
19590 C                                 =2   PY
19591 C                                 =3   PZ
19592 C                                 =4   ENERGY
19593 C
19594 C***********************************************************************
19595       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19596       SAVE
19597
19598       PARAMETER (RHOMAS =  0.766D0,
19599      &           DEPS   =  1.D-10,
19600      &           TINY   =  1.D-10)
19601
19602 C  input/output channels
19603       INTEGER LI,LO
19604       COMMON /POINOU/ LI,LO
19605 C  event debugging information
19606       INTEGER NMAXD
19607       PARAMETER (NMAXD=100)
19608       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19609      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19610       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19611      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19612 C  model switches and parameters
19613       CHARACTER*8 MDLNA
19614       INTEGER ISWMDL,IPAMDL
19615       DOUBLE PRECISION PARMDL
19616       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19617 C  some constants
19618       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19619       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19620      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19621 C  general process information
19622       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19623       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19624 C  global event kinematics and particle IDs
19625       INTEGER IFPAP,IFPAB
19626       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19627       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19628 C  data of c.m. system of Pomeron / Reggeon exchange
19629       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19630       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19631      &                 SIDP,CODP,SIFP,COFP
19632       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19633      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
19634      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
19635 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
19636       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19637       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19638       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19639      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19640 C  obsolete cut-off information
19641       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19642       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19643 C  currently activated parton density parametrizations
19644       CHARACTER*8 PDFNAM
19645       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19646       DOUBLE PRECISION PDFLAM,PDFQ2M
19647       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19648      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19649 C  hard scattering parameters used for most recent hard interaction
19650       INTEGER NFbeta,NF
19651       DOUBLE PRECISION ALQCD2,BQCD
19652       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19653 C  particles created by initial state evolution
19654       INTEGER MXISR1,MXISR2
19655       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19656       INTEGER IFLISR,IPOISR,IMXISR
19657       DOUBLE PRECISION PHISR
19658       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19659      &                IPOISR(2,2,MXISR2),IMXISR(2)
19660 C  light-cone x fractions and c.m. momenta of soft cut string ends
19661       INTEGER MAXSOF
19662       PARAMETER ( MAXSOF = 50 )
19663       INTEGER IJSI2,IJSI1
19664       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19665       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19666      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19667      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
19668 C  table of particle indices for recursive PHOJET calls
19669       INTEGER MAXIPX
19670       PARAMETER ( MAXIPX = 100 )
19671       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19672       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19673      &                IPOIX1,IPOIX2,IPOIX3
19674 C  hard scattering data
19675       INTEGER MSCAHD
19676       PARAMETER ( MSCAHD = 50 )
19677       INTEGER LSCAHD,LSC1HD,LSIDX,
19678      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19679       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19680       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19681      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19682      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19683      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19684      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19685      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19686      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19687
19688 C  standard particle data interface
19689       INTEGER NMXHEP
19690
19691       PARAMETER (NMXHEP=4000)
19692
19693       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19694       DOUBLE PRECISION PHEP,VHEP
19695       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19696      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19697      &                VHEP(4,NMXHEP)
19698 C  extension to standard particle data interface (PHOJET specific)
19699       INTEGER IMPART,IPHIST,ICOLOR
19700       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19701
19702 C  internal rejection counters
19703       INTEGER NMXJ
19704       PARAMETER (NMXJ=60)
19705       CHARACTER*10 REJTIT
19706       INTEGER IFAIL
19707       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19708 C  internal cross check information on hard scattering limits
19709       DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19710       COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19711 C  hard cross sections and MC selection weights
19712       INTEGER Max_pro_2
19713       PARAMETER ( Max_pro_2 = 16 )
19714       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19715      &  MH_acc_1,MH_acc_2
19716       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19717       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19718      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19719      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19720      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19721      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19722
19723       double precision pho_alphas
19724
19725       DIMENSION PC(4),IFLA(2),ICI(2,2)
19726
19727       IF(IJM1.EQ.-1) THEN
19728         DO 116 I=1,15
19729           ETAMI(1,I) = 1.D10
19730           ETAMA(1,I) = -1.D10
19731           ETAMI(2,I) = 1.D10
19732           ETAMA(2,I) = -1.D10
19733           XXMI(1,I) = 1.D0
19734           XXMA(1,I) = 0.D0
19735           XXMI(2,I) = 1.D0
19736           XXMA(2,I) = 0.D0
19737  116    CONTINUE
19738         CALL PHO_HARSCA(IJM1,1)
19739         CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19740
19741         RETURN
19742
19743       ELSE IF(IJM1.EQ.-2) THEN
19744
19745 C  output internal statistics
19746         IF(IDEB(23).GE.1) THEN
19747           WRITE(LO,'(/1X,A)')
19748      &      'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19749           DO 117 I=1,15
19750             WRITE(LO,'(5X,I3,4E13.5)')
19751      &        I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19752  117      CONTINUE
19753           WRITE(LO,'(1X,A)')
19754      &      'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19755           DO 118 I=1,15
19756             WRITE(LO,'(5X,I3,4E13.5)')
19757      &        I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
19758  118      CONTINUE
19759         ENDIF
19760         CALL PHO_HARSCA(IJM1,1)
19761         CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19762
19763         RETURN
19764       ENDIF
19765
19766       IREJ   = 0
19767 C  debug output
19768       IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19769   221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19770
19771 C  get mother data (exchange if first particle is a pomeron)
19772       IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19773         JM1 = IJM2
19774         JM2 = IJM1
19775       ELSE
19776         JM1 = IJM1
19777         JM2 = IJM2
19778       ENDIF
19779
19780       NPOSP(1) = JM1
19781       NPOSP(2) = JM2
19782       IDPDG1 = IDHEP(JM1)
19783       IDBAM1 = IMPART(JM1)
19784       IDPDG2 = IDHEP(JM2)
19785       IDBAM2 = IMPART(JM2)
19786
19787 C  store current status of /POEVT1/
19788       KHPOMS = KHPOM
19789       KSPOMS = KSPOM
19790       KSREGS = KSREG
19791       KHDIRS = KHDIR
19792       NHEPS  = NHEP
19793       IPOIS1 = IPOIX1
19794       IPOIS2 = IPOIX2
19795
19796 C  get nominal masses (photons: VDM assumption)
19797       DELMAS = 0.D0
19798       IF(IDHEP(JM1).EQ.22) THEN
19799         PMASSP(1) = RHOMAS+DELMAS
19800         PVIRTP(1) = PHEP(5,JM1)**2
19801       ELSE
19802         PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19803         PVIRTP(1) = 0.D0
19804       ENDIF
19805       IF(IDHEP(JM2).EQ.22) THEN
19806         PMASSP(2) = RHOMAS+DELMAS
19807         PVIRTP(2) = PHEP(5,JM2)**2
19808       ELSE
19809         PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19810         PVIRTP(2) = 0.D0
19811       ENDIF
19812
19813 C  calculate c.m. energy and check kinematics
19814       PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19815       PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19816       PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19817       PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19818       SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19819
19820       IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19821         WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19822      &    'energy smaller than two-particle threshold (event rejected)'
19823         CALL PHO_PREVNT(1)
19824         IREJ = 5
19825         GOTO 150
19826       ENDIF
19827       ECMP = SQRT(SS)
19828
19829       IF(IDEB(23).GE.5) THEN
19830         WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19831      &    'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19832         IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19833       ENDIF
19834
19835 C  Lorentz transformation into c.m. system
19836       DO 10 I=1,4
19837         GAMBEP(I) = PC(I)/ECMP
19838  10   CONTINUE
19839       CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19840      &           PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19841      &           PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19842 C  rotation angle: particle 1 moves along +z
19843       CODP = PC(3)/PTOT1
19844       SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19845       COFP = 1.D0
19846       SIFP = 0.D0
19847       IF(PTOT1*SIDP.GT.1.D-5) THEN
19848         COFP = PC(1)/(SIDP*PTOT1)
19849         SIFP = PC(2)/(SIDP*PTOT1)
19850         ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19851         COFP = COFP/ANORF
19852         SIFP = SIFP/ANORF
19853       ENDIF
19854 C  get CM momentum
19855       XM12 = PMASSP(1)**2
19856       XM22 = PMASSP(2)**2
19857       PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19858
19859 C  find particle combination
19860       II = 0
19861       IF(IDPDG2.EQ.IFPAP(2)) THEN
19862         IF(IDPDG1.EQ.IFPAP(1)) II = 1
19863       ELSE IF(IDPDG2.EQ.990) THEN
19864         IF(IDPDG1.EQ.IFPAP(1)) THEN
19865           II = 2
19866         ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19867           II = 3
19868         ELSE IF(IDPDG1.EQ.990) THEN
19869           II = 4
19870         ENDIF
19871       ENDIF
19872       IF(II.EQ.0) THEN
19873         IF(ISWMDL(14).GT.0) THEN
19874           II = 1
19875         ELSE
19876           WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19877      &      'invalid particle combination:',IDPDG1,IDPDG2
19878           CALL PHO_ABORT
19879         ENDIF
19880       ENDIF
19881
19882 C  select parton distribution functions from tables
19883       IF((MHPOM+MHDIR).GT.0) THEN
19884         CALL PHO_ACTPDF(IDPDG1,1)
19885         CALL PHO_ACTPDF(IDPDG2,2)
19886 C  initialize alpha_s calculation
19887         DUMMY = PHO_ALPHAS(0.D0,-4)
19888       ENDIF
19889
19890 C  interpolate hard cross sections and rejection weights
19891       CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19892      &            -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19893
19894       NTRY   = 10
19895
19896 C  position of first particle added to /POEVT2/
19897       NLOR1 = NHEP+1
19898
19899 C  ---------------- direct processes -----------------
19900
19901       IF(MHDIR.EQ.1) THEN
19902         CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19903         IF(IREJ.EQ.50) RETURN
19904         IF(IREJ.NE.0) GOTO 150
19905 C  write comments to /POEVT1/
19906         CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19907      &    X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19908      &    IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19909         CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19910      &    PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19911      &    ICA1,ICA2,IPOS,1)
19912         CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19913      &    PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19914      &    ICA1,ICA2,IPOS,1)
19915         CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19916      &    PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19917      &    IPOS1,1)
19918         CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19919      &    PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19920      &    IPOS2,1)
19921
19922 C  soft spectator partons
19923         ICA1  = 0
19924         ICA2  = 0
19925         ICB1  = 0
19926         ICB2  = 0
19927         IPDF1 = 0
19928         IPDF2 = 0
19929
19930 C  single resolved: QCD compton scattering
19931 C ------------------------------
19932         IF(NPROHD(1).EQ.10) THEN
19933 C  register hadron remnant
19934           CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19935           IPDF2 = 1000*IGRP(2)+ISET(2)
19936         ELSE IF(NPROHD(1).EQ.12) THEN
19937 C  register hadron remnant
19938           CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19939           IPDF1 = 1000*IGRP(1)+ISET(1)
19940
19941 C  single resolved: photon gluon fusion
19942 C ---------------------------
19943         ELSE IF(NPROHD(1).EQ.11) THEN
19944 C  register hadron remnant
19945           CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19946           IPDF2 = 1000*IGRP(2)+ISET(2)
19947         ELSE IF(NPROHD(1).EQ.13) THEN
19948 C  register hadron remnant
19949           CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19950           IPDF1 = 1000*IGRP(1)+ISET(1)
19951
19952 C  direct process (no remnant)
19953 C ----------------------------
19954         ELSE IF(NPROHD(1).EQ.14) THEN
19955
19956         ENDIF
19957
19958 C  write final high-pt partons to POEVT1
19959         IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19960           ICI(1,1) = ICA1
19961           ICI(1,2) = ICA2
19962           ICI(2,1) = ICB1
19963           ICI(2,2) = ICB2
19964           I = 1
19965           IFLA(1) = NINHD(I,1)
19966           IFLA(2) = NINHD(I,2)
19967 C  initial state radiation
19968           DO 130 K=1,2
19969             DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19970               KK = 1
19971  137          CONTINUE
19972               IFLB = IFLISR(K,IPA)
19973               IF(ABS(IFLB).LE.6) THEN
19974 C  partons
19975                 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19976                   IF(IFLB.EQ.0) THEN
19977                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19978      &                ICI(K,1),ICI(K,2),3)
19979                   ELSE IF(IFLB.GT.0) THEN
19980                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19981      &                ICI(K,1),ICI(K,2),4)
19982                   ELSE
19983                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19984      &                IC1,IC2,4)
19985                   ENDIF
19986                 ELSE
19987                   IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19988                     IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19989                       CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19990                       KK = KK+1
19991                       GOTO 137
19992                     ENDIF
19993                   ENDIF
19994                   IF(IFLB.EQ.0) THEN
19995                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19996      &                IC1,IC2,2)
19997                   ELSE
19998                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19999      &                ICI(K,1),ICI(K,2),2)
20000                   ENDIF
20001                 ENDIF
20002                 IIFL = IPHO_CNV1(IFLB)
20003
20004                 IFLA(K) = IFLA(K)-IFLB
20005                 IST = -1
20006               ELSE
20007 C  other particle
20008                 IIFL = IFLB
20009                 IC1 = 0
20010                 IC2 = 0
20011                 IST = 1
20012               ENDIF
20013               CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20014      &          PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
20015      &          IGEN,IC1,IC2,IPOS,1)
20016  135        CONTINUE
20017  130      CONTINUE
20018           ICOLOR(1,IPOS1-2) = ICI(1,1)
20019           ICOLOR(2,IPOS1-2) = ICI(1,2)
20020           ICOLOR(1,IPOS1-1) = ICI(2,1)
20021           ICOLOR(2,IPOS1-1) = ICI(2,2)
20022           CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20023      &      IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20024      &      NOUTHD(I,2),ICI(2,1),ICI(2,2))
20025           ICOLOR(1,IPOS1) = ICI(1,1)
20026           ICOLOR(2,IPOS1) = ICI(1,2)
20027           ICOLOR(1,IPOS2) = ICI(2,1)
20028           ICOLOR(2,IPOS2) = ICI(2,2)
20029           DO 140 K=1,2
20030             IPA = IPOISR(K,1,I)
20031             CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20032      &        PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20033      &        PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20034  140      CONTINUE
20035         ELSE
20036           ICOLOR(1,IPOS1-2) = ICA1
20037           ICOLOR(2,IPOS1-2) = ICA2
20038           ICOLOR(1,IPOS1-1) = ICB1
20039           ICOLOR(2,IPOS1-1) = ICB2
20040           CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
20041      &      NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
20042      &      NOUTHD(1,2),ICB1,ICB2)
20043           ICOLOR(1,IPOS1) = ICA1
20044           ICOLOR(2,IPOS1) = ICA2
20045           ICOLOR(1,IPOS2) = ICB1
20046           ICOLOR(2,IPOS2) = ICB2
20047           I = -1
20048           IF(ABS(NOUTHD(1,1)).GT.12) I = 1
20049           CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
20050      &      PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
20051           CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
20052      &      PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
20053         ENDIF
20054
20055 C  assign soft pt to spectators
20056         IF(ISWMDL(18).EQ.0) THEN
20057           IPOS2 = IPOS2-1
20058           CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
20059           IF(IREJ.NE.0) THEN
20060             IFAIL(26) = IFAIL(26) + 1
20061             GOTO 150
20062           ENDIF
20063
20064         ENDIF
20065
20066 C  ----------------- resolved processes -------------------
20067
20068 C  single Reggeon exchange
20069 C ----------------------------
20070       ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
20071 C  flavours
20072         CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
20073         IF(IREJ.NE.0) THEN
20074           IFAIL(24) = IFAIL(24)+1
20075           GOTO 150
20076         ENDIF
20077
20078 C  colors
20079         CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
20080         IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
20081      &     .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
20082           CALL PHO_SWAPI(ICA1,ICB1)
20083         ENDIF
20084         ECMH = ECMP/2.D0
20085
20086 C  registration
20087
20088 C  DPMJET call with special projectile / target
20089 **sr leading tab removed
20090         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
20091 **
20092           CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
20093      &               ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
20094           CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
20095      &               ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
20096 C  default treatment
20097         ELSE
20098           CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
20099      &      -1,IGEN,ICA1,0,IPOS1,1)
20100           CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
20101      &      -1,IGEN,ICB1,0,IPOS2,1)
20102         ENDIF
20103
20104 C  soft pt assignment
20105         IF(ISWMDL(18).EQ.0) THEN
20106           CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20107           IF(IREJ.NE.0) THEN
20108             IFAIL(25) = IFAIL(25) + 1
20109             GOTO 150
20110           ENDIF
20111         ENDIF
20112 C
20113 C  multi Reggeon / Pomeron exchange
20114 C----------------------------------------
20115       ELSE
20116 C  parton configuration
20117
20118         CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
20119      &              MHPAR1,MHPAR2,IREJ)
20120
20121         IF(IREJ.EQ.50) RETURN
20122         IF(IREJ.NE.0) GOTO 150
20123
20124 C  register particles
20125         IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
20126      &    'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
20127      &    MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
20128
20129 C  register soft partons
20130         IF(IVAL1.NE.0) THEN
20131           IF(IVAL1.LT.0) THEN
20132             IND1 = 3
20133             IVAL1=-IVAL1
20134           ELSE
20135             IND1 = 2
20136           ENDIF
20137         ELSE IF(MSPOM.EQ.0) THEN
20138           IND1 = 4
20139         ELSE
20140           IND1 = 1
20141         ENDIF
20142         IF(IVAL2.NE.0) THEN
20143           IF(IVAL2.LT.0) THEN
20144             IND2 = 3
20145             IVAL2=-IVAL2
20146           ELSE
20147             IND2 = 2
20148           ENDIF
20149         ELSE IF(MSPOM.EQ.0) THEN
20150           IND2 = 4
20151         ELSE
20152           IND2 = 1
20153         ENDIF
20154
20155         IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
20156      &    'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
20157
20158 C  soft Pomeron final states
20159 C -----------------------------------
20160         K = MSPOM+MHPOM+MSREG
20161         DO 50 I=1,MSPOM
20162
20163           CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
20164           IF(IREJ.NE.0) THEN
20165             IFAIL(8) = IFAIL(8) + 1
20166             GOTO 150
20167           ENDIF
20168 C
20169  50     CONTINUE
20170
20171 C  soft Reggeon final states
20172 C -----------------------------------------
20173         DO 75 I=1,MSREG
20174 C  flavours
20175           CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
20176           IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
20177             CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
20178           ELSE
20179             CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
20180           ENDIF
20181
20182 C  colors
20183           CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
20184           IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
20185      &      .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
20186      &      CALL PHO_SWAPI(ICA1,ICB1)
20187 C  registration
20188           CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
20189      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
20190      &      I,IGEN,ICA1,ICA2,IPOS1,1)
20191           IND1 = IND1+1
20192           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
20193      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
20194      &      I,IGEN,ICB1,ICB2,IPOS2,1)
20195           IND2 = IND2+1
20196
20197           IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
20198      &      'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
20199      &      IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
20200
20201 C  soft pt assignment
20202           IF(ISWMDL(18).EQ.0) THEN
20203             CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20204             IF(IREJ.NE.0) THEN
20205               IFAIL(25) = IFAIL(25) + 1
20206               GOTO 150
20207             ENDIF
20208           ENDIF
20209
20210  75     CONTINUE
20211
20212 C  hard Pomeron final states
20213 C ------------------------------------
20214         IND1 = MSPAR1
20215         IND2 = MSPAR2
20216
20217         DO 100 L=1,MHPOM
20218           I = LSIDX(L)
20219
20220           IFLI1 = IPHO_CNV1(N0INHD(I,1))
20221           IFLI2 = IPHO_CNV1(N0INHD(I,2))
20222           IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20223           IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20224
20225 C  write comments to /POEVT1/
20226           CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20227      &      X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20228      &      IFLO1,IFLO2,IPOS,1)
20229           I1 = 8*I-7
20230           IPDF = 1000*IGRP(1)+ISET(1)
20231           CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20232      &      PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20233      &      ICA1,ICA2,IPOS,1)
20234           IPDF = 1000*IGRP(2)+ISET(2)
20235           CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20236      &      PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20237      &      ICB1,ICB2,IPOS,1)
20238           I1 = 8*I-3
20239           IPDF = 1000*IGRP(1)+ISET(1)
20240           CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20241      &      PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20242      &      ICA1,ICA2,IPOS1,1)
20243           IPDF = 1000*IGRP(2)+ISET(2)
20244           CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20245      &      PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20246      &      ICB1,ICB2,IPOS2,1)
20247
20248 C  spectator partons belonging to hard interaction
20249           IF(IVAL1.EQ.I) THEN
20250             IVQ = 1
20251             IND = 1
20252           ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20253             IVQ = 0
20254             IND = 1
20255           ELSE
20256             IVQ = -1
20257             IND = IND1
20258           ENDIF
20259           CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20260           IF(IVQ.LT.0) IND1 = IND1-IUSED
20261           IF(IVAL2.EQ.I) THEN
20262             IVQ = 1
20263             IND = 1
20264           ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20265             IVQ = 0
20266             IND = 1
20267           ELSE
20268             IVQ = -1
20269             IND = IND2
20270           ENDIF
20271           CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20272           IF(IVQ.LT.0) IND2 = IND2-IUSED
20273 C
20274 C  register hard scattered partons
20275           IF((ISWMDL(8).GE.2)
20276      &       .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20277             ICI(1,1) = ICA1
20278             ICI(1,2) = ICA2
20279             ICI(2,1) = ICB1
20280             ICI(2,2) = ICB2
20281             IFLA(1) = NINHD(I,1)
20282             IFLA(2) = NINHD(I,2)
20283 C  initial state radiation
20284             DO 230 K=1,2
20285               DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20286                 KK = 1
20287  237            CONTINUE
20288                 IFLB = IFLISR(K,IPA)
20289                 IF(ABS(IFLB).LE.6) THEN
20290 C  partons
20291                   IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20292                     IF(IFLB.EQ.0) THEN
20293                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20294      &                  ICI(K,1),ICI(K,2),3)
20295                     ELSE IF(IFLB.GT.0) THEN
20296                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20297      &                  ICI(K,1),ICI(K,2),4)
20298                     ELSE
20299                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20300      &                  ICI(K,2),IC1,IC2,4)
20301                     ENDIF
20302                   ELSE
20303                     IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20304                       IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20305                         CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20306                         KK = KK+1
20307                         GOTO 237
20308                       ENDIF
20309                     ENDIF
20310                     IF(IFLB.EQ.0) THEN
20311                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20312      &                  ICI(K,2),IC1,IC2,2)
20313                     ELSE
20314                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20315      &                  ICI(K,1),ICI(K,2),2)
20316                     ENDIF
20317                   ENDIF
20318                   IIFL = IPHO_CNV1(IFLB)
20319
20320                   IFLA(K)  = IFLA(K)-IFLB
20321                   IST = -1
20322                 ELSE
20323 C  other particles
20324                   IIFL = IFLB
20325                   IC1 = 0
20326                   IC2 = 0
20327                   IST = 1
20328                 ENDIF
20329                 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20330      &            PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20331      &            L*100+K,IGEN,IC1,IC2,IPOS,1)
20332  235          CONTINUE
20333  230        CONTINUE
20334             ICOLOR(1,IPOS1-2) = ICI(1,1)
20335             ICOLOR(2,IPOS1-2) = ICI(1,2)
20336             ICOLOR(1,IPOS1-1) = ICI(2,1)
20337             ICOLOR(2,IPOS1-1) = ICI(2,2)
20338             CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20339      &        IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20340      &        NOUTHD(I,2),ICI(2,1),ICI(2,2))
20341             ICOLOR(1,IPOS1) = ICI(1,1)
20342             ICOLOR(2,IPOS1) = ICI(1,2)
20343             ICOLOR(1,IPOS2) = ICI(2,1)
20344             ICOLOR(2,IPOS2) = ICI(2,2)
20345             DO 240 K=1,2
20346               IPA = IPOISR(K,1,I)
20347               CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20348      &          PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20349      &          PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20350  240        CONTINUE
20351           ELSE
20352             ICOLOR(1,IPOS1-2) = ICA1
20353             ICOLOR(2,IPOS1-2) = ICA2
20354             ICOLOR(1,IPOS1-1) = ICB1
20355             ICOLOR(2,IPOS1-1) = ICB2
20356             CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20357      &        NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20358      &        NOUTHD(I,2),ICB1,ICB2)
20359             ICOLOR(1,IPOS1) = ICA1
20360             ICOLOR(2,IPOS1) = ICA2
20361             ICOLOR(1,IPOS2) = ICB1
20362             ICOLOR(2,IPOS2) = ICB2
20363             I1 = 8*I-3
20364             CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20365      &        PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20366      &        ICA1,ICA2,IPOS,1)
20367             CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20368      &        PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20369      &        ICB1,ICB2,IPOS,1)
20370           ENDIF
20371  100    CONTINUE
20372 C  end of resolved parton registration
20373       ENDIF
20374
20375       IF(MHDIR+MHPOM.GT.0) THEN
20376
20377         IF(ISWMDL(29).GE.1) THEN
20378 C  primordial kt of hard scattering
20379           CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20380           IF(IREJ.NE.0) THEN
20381             IFAIL(27) = IFAIL(27)+1
20382             GOTO 150
20383           ENDIF
20384         ELSE IF(ISWMDL(24).GE.0) THEN
20385 C  give "soft" pt only to soft (spectator) partons in hard processes
20386           CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20387           IF(IREJ.NE.0) THEN
20388             IFAIL(26) = IFAIL(26)+1
20389             GOTO 150
20390           ENDIF
20391         ENDIF
20392
20393       ENDIF
20394
20395 C  give "soft" pt to partons in soft Pomerons
20396       IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20397         CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20398         IF(IREJ.NE.0) THEN
20399           IFAIL(25) = IFAIL(25) + 1
20400           GOTO 150
20401         ENDIF
20402       ENDIF
20403
20404 C  boost back to lab frame
20405       CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20406      &  GAMBEP(1),GAMBEP(2),GAMBEP(3))
20407       RETURN
20408
20409 C  rejection treatment
20410  150  CONTINUE
20411       IFAIL(2) = IFAIL(2)+1
20412 C  reset counters
20413       KSPOM = KSPOMS
20414       KHPOM = KHPOMS
20415       KHDIR = KHDIRS
20416       KSREG = KSREGS
20417 C  reset mother-daugther relations
20418       JDAHEP(1,JM1) = 0
20419       JDAHEP(2,JM1) = 0
20420       JDAHEP(1,JM2) = 0
20421       JDAHEP(2,JM2) = 0
20422       ISTHEP(JM1) = 1
20423       ISTHEP(JM2) = 1
20424       IPOIX1 = IPOIS1
20425       IPOIX2 = IPOIS2
20426       NHEP   = NHEPS
20427 C  debug
20428       IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20429      &  'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20430      &  MSPOM,MHPOM,MSREG,MHDIR
20431       RETURN
20432
20433       END
20434
20435 *$ CREATE PHO_HARCOL.FOR
20436 *COPY PHO_HARCOL
20437 CDECK  ID>, PHO_HARCOL
20438       SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20439      &                  IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20440 C*********************************************************************
20441 C
20442 C     calculate color flow for hard resolved process
20443 C
20444 C     input:    IP1..4  flavour of partons (PDG convention)
20445 C               V       parton subprocess Mandelstam variable  V = t/s
20446 C                       (lightcone momenta assumed)
20447 C               ICA,ICB color labels
20448 C               MSPR    process number
20449 C                       -1   initialization of statistics
20450 C                       -2   output of statistics
20451 C
20452 C     output:   ICC,ICD color label of final partons
20453 C
20454 C     (it is possible to use the same variables for in and output)
20455 C
20456 C**********************************************************************
20457       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20458       SAVE
20459
20460 C  input/output channels
20461       INTEGER LI,LO
20462       COMMON /POINOU/ LI,LO
20463 C  event debugging information
20464       INTEGER NMAXD
20465       PARAMETER (NMAXD=100)
20466       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20467      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20468       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20469      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20470 C  model switches and parameters
20471       CHARACTER*8 MDLNA
20472       INTEGER ISWMDL,IPAMDL
20473       DOUBLE PRECISION PARMDL
20474       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20475 C  names of hard scattering processes
20476       INTEGER Max_pro_1
20477       PARAMETER ( Max_pro_1 = 16 )
20478       CHARACTER*18 PROC
20479       COMMON /POHPRO/ PROC(0:Max_pro_1)
20480
20481       DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20482
20483 C  initialization
20484       IF(MSPR.EQ.-1) THEN
20485         DO 200 I=1,8
20486           DO 210 K=1,5
20487             ICONF(I,K) = 0
20488  210      CONTINUE
20489           IRECN(I,1) = 0
20490           IRECN(I,2) = 0
20491  200    CONTINUE
20492         RETURN
20493 C  output of statistics
20494       ELSE IF(MSPR.EQ.-2) THEN
20495         IF(IDEB(26).LT.1) RETURN
20496         WRITE(LO,'(/1X,A,/1X,A)')
20497      &    'PHO_HARCOL: sampled color configurations',
20498      &    '----------------------------------------'
20499         WRITE(LO,'(6X,A,15X,A)')
20500      &    'diagram                  color configurations (1-4)','sum'
20501         DO 300 I=1,8
20502           DO 310 K=1,4
20503             ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20504  310      CONTINUE
20505           WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20506  300    CONTINUE
20507         IF(ISWMDL(11).GE.2) THEN
20508           WRITE(LO,'(/6X,A)')
20509      &      'diagram             with   /   without color re-connection'
20510           DO 320 I=1,8
20511             WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20512  320      CONTINUE
20513         ENDIF
20514         RETURN
20515       ENDIF
20516 C
20517 C  gluons: first color positive, quarks second color zero
20518       IF(IP1.EQ.0) THEN
20519         IF(ICA1.LT.0) THEN
20520           I = ICA2
20521           ICA2 = ICA1
20522           ICA1 = I
20523         ENDIF
20524       ELSE
20525         ICA2 = 0
20526       ENDIF
20527       IF(IP2.EQ.0) THEN
20528         IF(ICB1.LT.0) THEN
20529           I = ICB2
20530           ICB2 = ICB1
20531           ICB1 = I
20532         ENDIF
20533       ELSE
20534         ICB2 = 0
20535       ENDIF
20536       IC2 = 0
20537       IC4 = 0
20538 C  debug output
20539       IF(IDEB(26).GE.15)
20540      &  WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20541      &  'PHO_HARCOL: process',MSPR,
20542      &  'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20543 C
20544       IRC = 0
20545       IF(IPAMDL(21).EQ.1) THEN
20546 C
20547 C  soft color re-connection option
20548 C
20549         IF(MSPR.EQ.1) THEN
20550 C  hard g g final state, only g g --> g g
20551           IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20552             IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20553               IC1 = ICA1
20554               IC2 = ICA2
20555               IC3 = ICB1
20556               IC4 = ICB2
20557               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20558               IRC = 1
20559               GOTO 100
20560             ENDIF
20561           ENDIF
20562         ELSE IF(MSPR.EQ.3) THEN
20563 C  hard q g final state
20564           IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20565             IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20566               IC1 = ICA1
20567               IC2 = ICA2
20568               IC3 = ICB1
20569               IC4 = ICB2
20570               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20571               IRC = 1
20572               GOTO 100
20573             ENDIF
20574           ENDIF
20575         ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20576 C  hard q q final state
20577           IF(ICA1.NE.-ICB1) THEN
20578             IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20579               IC1 = ICA1
20580               IC2 = ICA2
20581               IC3 = ICB1
20582               IC4 = ICB2
20583               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20584               IRC = 1
20585               GOTO 100
20586             ENDIF
20587           ENDIF
20588         ENDIF
20589         IRECN(MSPR,2) = IRECN(MSPR,2)+1
20590       ENDIF
20591 C
20592       IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20593 C
20594 C  large Nc limit of all graphs
20595 C
20596         IF(MSPR.EQ.1) THEN
20597 C  g g --> g g
20598           IF(DT_RNDM(V).GT.0.5D0) THEN
20599             IC1 = ICB1
20600             IC2 = ICA2
20601             IC3 = ICA1
20602             IC4 = ICB2
20603             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20604           ELSE
20605             IC1 = ICA1
20606             IC2 = ICB2
20607             IC3 = ICB1
20608             IC4 = ICA2
20609             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20610           ENDIF
20611         ELSE IF(MSPR.EQ.2) THEN
20612 C  q qb --> g g
20613           CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20614           IF(ICA1.LT.0) THEN
20615             IC1 = I1
20616             IC2 = ICA1
20617             IC3 = ICB1
20618             IC4 = I2
20619             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20620           ELSE
20621             IC1 = ICA1
20622             IC2 = I2
20623             IC3 = I1
20624             IC4 = ICB1
20625             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20626           ENDIF
20627         ELSE IF(MSPR.EQ.3) THEN
20628 C  q g --> q g
20629           IF(DT_RNDM(V).LT.0.5D0) THEN
20630             IF(IP1+IP2.GT.0) THEN
20631               IC1 = ICB1
20632               IC2 = ICA2
20633               IC3 = ICA1
20634               IC4 = ICB2
20635             ELSE IF(IP1.LT.0) THEN
20636               IC1 = ICB2
20637               IC3 = ICB1
20638               IC4 = ICA1
20639             ELSE
20640               IC1 = ICA1
20641               IC2 = ICB1
20642               IC3 = ICA2
20643             ENDIF
20644             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20645           ELSE
20646             IF(IP1.GT.0) THEN
20647               CALL PHO_HARCOR(-ICA1,ICB2)
20648               IC1 = ICA1
20649               IC3 = ICB1
20650               IC4 = -ICA1
20651             ELSE IF(IP2.GT.0) THEN
20652               CALL PHO_HARCOR(-ICB1,ICA2)
20653               IC1 = ICA1
20654               IC2 = -ICB1
20655               IC3 = ICB1
20656             ELSE IF(IP1.LT.0) THEN
20657               CALL PHO_HARCOR(-ICA1,ICB1)
20658               IC1 = ICA1
20659               IC3 = -ICA1
20660               IC4 = ICB2
20661             ELSE IF(IP2.LT.0) THEN
20662               CALL PHO_HARCOR(-ICB1,ICA1)
20663               IC1 = -ICB1
20664               IC2 = ICA2
20665               IC3 = ICB1
20666             ENDIF
20667             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20668           ENDIF
20669         ELSE IF(MSPR.EQ.4) THEN
20670 C  g g --> q qb
20671           IC1 = ICA1
20672           IC3 = ICB2
20673           CALL PHO_HARCOR(-ICB1,ICA2)
20674           IF(ICB2.EQ.-ICB1) IC3 = ICA2
20675           IF(IP3*IC1.LT.0) THEN
20676             I = IC1
20677             IC1 = IC3
20678             IC3 = I
20679           ENDIF
20680           ICONF(MSPR,2) = ICONF(MSPR,2)+1
20681         ELSE IF(MSPR.EQ.5) THEN
20682 C  q qb --> q qb
20683           IF(DT_RNDM(V).LT.0.5D0) THEN
20684             IF(ICA1*IP3.LT.0) THEN
20685               IC1 = ICB1
20686               IC3 = ICA1
20687             ELSE
20688               IC1 = ICA1
20689               IC3 = ICB1
20690             ENDIF
20691             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20692           ELSE
20693             IF(ICA1*IP3.LT.0) THEN
20694               IC1 = -ICA1
20695               IC3 = ICA1
20696             ELSE
20697               IC1 = ICA1
20698               IC3 = -ICA1
20699             ENDIF
20700             CALL PHO_HARCOR(-ICA1,ICB1)
20701             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20702           ENDIF
20703         ELSE IF(MSPR.EQ.6) THEN
20704 C  q qb --> qp qbp
20705           IF(ICA1*IP3.LT.0) THEN
20706             IC1 = ICB1
20707             IC3 = ICA1
20708             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20709           ELSE
20710             IC1 = ICA1
20711             IC3 = ICB1
20712             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20713           ENDIF
20714         ELSE IF(MSPR.EQ.7) THEN
20715 C  q q --> q q
20716           IF(DT_RNDM(V).LT.0.5D0) THEN
20717             IC1 = ICA1
20718             IC3 = ICB1
20719             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20720           ELSE
20721             IC1 = ICB1
20722             IC3 = ICA1
20723             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20724           ENDIF
20725         ELSE IF(MSPR.EQ.8) THEN
20726 C  q qp --> q qp
20727           IF(IP1*IP2.GT.0) THEN
20728             IF(IP3.EQ.IP1) THEN
20729               IC1 = ICB1
20730               IC3 = ICA1
20731             ELSE
20732               IC1 = ICA1
20733               IC3 = ICB1
20734             ENDIF
20735             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20736           ELSE
20737             IF(ICA1*IP3.LT.0) THEN
20738               IC1 = -ICA1
20739               IC3 = ICA1
20740             ELSE
20741               IC1 = ICA1
20742               IC3 = -ICA1
20743             ENDIF
20744             CALL PHO_HARCOR(-ICA1,ICB1)
20745             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20746           ENDIF
20747         ELSE
20748 C  unknown process
20749           WRITE(LO,'(/1X,A,I3)')
20750      &      'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20751           CALL PHO_ABORT
20752         ENDIF
20753 C
20754       ELSE
20755 C
20756 C  color flow according to QCD leading order matrix element
20757 C
20758         U = -(1.D0+V)
20759         IF(MSPR.EQ.1) THEN
20760 C  g g --> g g
20761           PC(1) = 1/V**2  +2.D0/V    +3.D0  +2.D0*V    +V**2
20762           PC(2) = 1/U**2  +2.D0/U    +3.D0  +2.D0*U    +U**2
20763           PC(3) = (V/U)**2+2.D0*(V/U)+3.D0  +2.D0*(U/V)+(U/V)**2
20764           XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20765           PCS = 0.D0
20766           DO 110 I=1,3
20767             PCS = PCS+PC(I)
20768             IF(XI.LT.PCS) GOTO 120
20769  110      CONTINUE
20770  120      CONTINUE
20771           IF(I.EQ.1) THEN
20772             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20773             IF(DT_RNDM(V).GT.0.5D0) THEN
20774               IC1 = I1
20775               IC2 = ICA2
20776               IC3 = ICB1
20777               IC4 = I2
20778               CALL PHO_HARCOR(-ICB2,ICA1)
20779               IF(ICB1.EQ.-ICB2) IC3 = ICA1
20780             ELSE
20781               IC1 = ICA1
20782               IC2 = I2
20783               IC3 = I1
20784               IC4 = ICB2
20785               CALL PHO_HARCOR(-ICB1,ICA2)
20786               IF(ICB2.EQ.-ICB1) IC4 = ICA2
20787             ENDIF
20788           ELSE IF(I.EQ.2) THEN
20789             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20790             IF(DT_RNDM(U).GT.0.5D0) THEN
20791               IC1 = ICB1
20792               IC2 = I2
20793               IC3 = I1
20794               IC4 = ICA2
20795               CALL PHO_HARCOR(-ICB2,ICA1)
20796               IF(ICB1.EQ.-ICB2) IC1 = ICA1
20797             ELSE
20798               IC1 = I1
20799               IC2 = ICB2
20800               IC3 = ICA1
20801               IC4 = I2
20802               CALL PHO_HARCOR(-ICB1,ICA2)
20803               IF(ICB2.EQ.-ICB1) IC2 = ICA2
20804             ENDIF
20805           ELSE
20806             IF(DT_RNDM(V).GT.0.5D0) THEN
20807               IC1 = ICB1
20808               IC2 = ICA2
20809               IC3 = ICA1
20810               IC4 = ICB2
20811             ELSE
20812               IC1 = ICA1
20813               IC2 = ICB2
20814               IC3 = ICB1
20815               IC4 = ICA2
20816             ENDIF
20817           ENDIF
20818           ICONF(MSPR,I) = ICONF(MSPR,I)+1
20819         ELSE IF(MSPR.EQ.2) THEN
20820 C  q qb --> g g
20821           PC(1) = U/V-2.D0*U**2
20822           PC(2) = V/U-2.D0*V**2
20823           CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20824           XI = (PC(1)+PC(2))*DT_RNDM(U)
20825           IF(XI.LT.PC(1)) THEN
20826             IF(ICA1.GT.0) THEN
20827               IC1 = ICA1
20828               IC2 = I2
20829               IC3 = I1
20830               IC4 = ICB1
20831               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20832             ELSE
20833               IC1 = I1
20834               IC2 = ICA1
20835               IC3 = ICB1
20836               IC4 = I2
20837               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20838             ENDIF
20839           ELSE
20840             IF(ICA1.GT.0) THEN
20841               IC1 = I1
20842               IC2 = ICB1
20843               IC3 = ICA1
20844               IC4 = I2
20845               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20846             ELSE
20847               IC1 = ICB1
20848               IC2 = I2
20849               IC3 = I1
20850               IC4 = ICA1
20851               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20852             ENDIF
20853           ENDIF
20854         ELSE IF(MSPR.EQ.3) THEN
20855 C  q g --> q g
20856           PC(1) = 2.D0*(U/V)**2-U
20857           PC(2) = 2.D0/V**2-1.D0/U
20858           XI = (PC(1)+PC(2))*DT_RNDM(V)
20859           IF(XI.LT.PC(1)) THEN
20860             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20861             IF(IP1.GT.0) THEN
20862               IC1 = I1
20863               IC3 = ICB1
20864               IC4 = I2
20865               CALL PHO_HARCOR(-ICA1,ICB2)
20866               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20867             ELSE IF(IP1.LT.0) THEN
20868               IC1 = I2
20869               IC3 = I1
20870               IC4 = ICB2
20871               CALL PHO_HARCOR(-ICA1,ICB1)
20872               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20873             ELSE IF(IP2.GT.0) THEN
20874               IC1 = ICA1
20875               IC2 = I2
20876               IC3 = I1
20877               CALL PHO_HARCOR(-ICB1,ICA2)
20878               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20879             ELSE
20880               IC1 = I1
20881               IC2 = ICA2
20882               IC3 = I2
20883               CALL PHO_HARCOR(-ICB1,ICA1)
20884               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20885             ENDIF
20886           ELSE
20887             IF(IP1.GT.0) THEN
20888               IC1 = ICB1
20889               IC3 = ICA1
20890               IC4 = ICB2
20891               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20892             ELSE IF(IP1.LT.0) THEN
20893               IC1 = ICB2
20894               IC3 = ICB1
20895               IC4 = ICA1
20896               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20897             ELSE IF(IP2.GT.0) THEN
20898               IC1 = ICB1
20899               IC2 = ICA2
20900               IC3 = ICA1
20901               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20902             ELSE
20903               IC1 = ICA1
20904               IC2 = ICB1
20905               IC3 = ICA2
20906               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20907             ENDIF
20908           ENDIF
20909         ELSE IF(MSPR.EQ.4) THEN
20910 C  g g --> q qb
20911           PC(1) = U/V-2.D0*U**2
20912           PC(2) = V/U-2.D0*V**2
20913           XI = (PC(1)+PC(2))*DT_RNDM(U)
20914           IF(XI.LT.PC(1)) THEN
20915             IF(IP3.GT.0) THEN
20916               IC1 = ICA1
20917               IC3 = ICB2
20918               CALL PHO_HARCOR(-ICB1,ICA2)
20919               IF(ICB2.EQ.-ICB1) IC3 = ICA2
20920               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20921             ELSE
20922               IC1 = ICA2
20923               IC3 = ICB1
20924               CALL PHO_HARCOR(-ICB2,ICA1)
20925               IF(ICB1.EQ.-ICB2) IC3 = ICA1
20926               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20927             ENDIF
20928           ELSE
20929             IF(IP3.GT.0) THEN
20930               IC1 = ICB1
20931               IC3 = ICA2
20932               CALL PHO_HARCOR(-ICB2,ICA1)
20933               IF(ICB1.EQ.-ICB2) IC1 = ICA1
20934               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20935             ELSE
20936               IC1 = ICB2
20937               IC3 = ICA1
20938               CALL PHO_HARCOR(-ICB1,ICA2)
20939               IF(ICB2.EQ.-ICB1) IC1 = ICA2
20940               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20941             ENDIF
20942           ENDIF
20943         ELSE IF(MSPR.EQ.5) THEN
20944 C  q qb --> q qb
20945           PC(1) = (1.D0+U**2)/V**2
20946           PC(2) = (V**2+U**2)
20947           XI = (PC(1)+PC(2))*DT_RNDM(V)
20948           IF(XI.LT.PC(1)) THEN
20949             CALL PHO_HARCOR(-ICB1,ICA1)
20950             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20951             IF(IP3.GT.0) THEN
20952               IC1 = I1
20953               IC3 = I2
20954               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20955             ELSE
20956               IC1 = I2
20957               IC3 = I1
20958               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20959             ENDIF
20960           ELSE
20961             IF(IP3.GT.0) THEN
20962               IC1 = MAX(ICA1,ICB1)
20963               IC3 = MIN(ICA1,ICB1)
20964               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20965             ELSE
20966               IC1 = MIN(ICA1,ICB1)
20967               IC3 = MAX(ICA1,ICB1)
20968               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20969             ENDIF
20970           ENDIF
20971         ELSE IF(MSPR.EQ.6) THEN
20972 C  q qb --> qp qpb
20973           IF(IP3.GT.0) THEN
20974             IC1 = MAX(ICA1,ICB1)
20975             IC3 = MIN(ICA1,ICB1)
20976             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20977           ELSE
20978             IC1 = MIN(ICA1,ICB1)
20979             IC3 = MAX(ICA1,ICB1)
20980             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20981           ENDIF
20982         ELSE IF(MSPR.EQ.7) THEN
20983 C  q q --> q q
20984           PC(1) = (1.D0+U**2)/V**2
20985           PC(2) = (1.D0+V**2)/U**2
20986           XI = (PC(1)+PC(2))*DT_RNDM(U)
20987           IF(XI.LT.PC(1)) THEN
20988             IC1 = ICB1
20989             IC3 = ICA1
20990             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20991           ELSE
20992             IC1 = ICA1
20993             IC3 = ICB1
20994             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20995           ENDIF
20996         ELSE IF(MSPR.EQ.8) THEN
20997 C  q qp --> q qp
20998           IF(IP1*IP2.LT.0) THEN
20999             CALL PHO_HARCOR(-ICB1,ICA1)
21000             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
21001             IF(IP1.GT.0) THEN
21002               IC1 = I1
21003               IC3 = I2
21004               ICONF(MSPR,1) = ICONF(MSPR,1)+1
21005             ELSE
21006               IC1 = I2
21007               IC3 = I1
21008               ICONF(MSPR,2) = ICONF(MSPR,2)+1
21009             ENDIF
21010           ELSE
21011             IC1 = ICB1
21012             IC3 = ICA1
21013             ICONF(MSPR,3) = ICONF(MSPR,3)+1
21014           ENDIF
21015
21016         ELSE IF(MSPR.EQ.10) THEN
21017 C  gam q --> q g
21018           CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
21019           IF(IP3.EQ.0) THEN
21020             CALL PHO_SWAPI(IC1,IC3)
21021             CALL PHO_SWAPI(IC2,IC4)
21022           ENDIF
21023         ELSE IF(MSPR.EQ.11) THEN
21024 C  gam g --> q q
21025           IC1 = ICB1
21026           IC3 = ICB2
21027           IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
21028         ELSE IF(MSPR.EQ.12) THEN
21029 C  q gam --> q g
21030           CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
21031           IF(IP3.EQ.0) THEN
21032             CALL PHO_SWAPI(IC1,IC3)
21033             CALL PHO_SWAPI(IC2,IC4)
21034           ENDIF
21035         ELSE IF(MSPR.EQ.13) THEN
21036 C  g gam --> q q
21037           IC1 = ICA1
21038           IC3 = ICA2
21039           IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
21040         ELSE IF(MSPR.EQ.14) THEN
21041           IF(ABS(IP3).GT.12) THEN
21042             IC1 = 0
21043             IC3 = 0
21044           ELSE
21045             CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
21046             IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
21047           ENDIF
21048         ELSE
21049 C  unknown process
21050           WRITE(LO,'(/1X,A,I3)')
21051      &      'PHO_HARCOL:ERROR:invalid process number',MSPR
21052           CALL PHO_ABORT
21053         ENDIF
21054       ENDIF
21055 C
21056  100  CONTINUE
21057 C  debug output
21058       IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
21059      &    'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
21060 C  color connection?
21061 *     IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
21062 *    &  (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
21063 *    &  .OR.(IC2.EQ.0))) THEN
21064 C  color exchange?
21065 *       IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
21066 *    &     .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
21067 *         IF(IRC.NE.1) THEN
21068 *           WRITE(LO,'(1X,A,I10,I3)')
21069 *    &        'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
21070 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
21071 *    &        'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
21072 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
21073 *    &        'final partons and colors  ',IP3,IC1,IC2,IP4,IC3,IC4
21074 *         ENDIF
21075 *         IRC = 0
21076 *       ENDIF
21077 *     ENDIF
21078 *     IF(IRC.EQ.1) THEN
21079 *           WRITE(LO,'(1X,A,I10,I3)')
21080 *    &        'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
21081 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
21082 *    &        'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
21083 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
21084 *    &        'final partons and colors  ',IP3,IC1,IC2,IP4,IC3,IC4
21085 *     ENDIF
21086 C
21087       ICC1 = IC1
21088       ICC2 = IC2
21089       ICD1 = IC3
21090       ICD2 = IC4
21091
21092       END
21093
21094 *$ CREATE PHO_HARCOR.FOR
21095 *COPY PHO_HARCOR
21096 CDECK  ID>, PHO_HARCOR
21097       SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
21098 C***********************************************************************
21099 C
21100 C     substituite color in /POEVT2/
21101 C
21102 C     input:    ICOLD   old color
21103 C               ICNEW   new color
21104 C
21105 C***********************************************************************
21106       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21107       SAVE
21108
21109 C  input/output channels
21110       INTEGER LI,LO
21111       COMMON /POINOU/ LI,LO
21112
21113 C  standard particle data interface
21114       INTEGER NMXHEP
21115
21116       PARAMETER (NMXHEP=4000)
21117
21118       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21119       DOUBLE PRECISION PHEP,VHEP
21120       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21121      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21122      &                VHEP(4,NMXHEP)
21123 C  extension to standard particle data interface (PHOJET specific)
21124       INTEGER IMPART,IPHIST,ICOLOR
21125       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21126
21127       DO 100 I=NHEP,3,-1
21128         IF(ISTHEP(I).EQ.-1) THEN
21129           IF(ICOLOR(1,I).EQ.ICOLD) THEN
21130             ICOLOR(1,I) = ICNEW
21131             RETURN
21132           ELSE IF(IDHEP(I).EQ.21) THEN
21133             IF(ICOLOR(2,I).EQ.ICOLD) THEN
21134               ICOLOR(2,I) = ICNEW
21135               RETURN
21136             ENDIF
21137           ENDIF
21138 *       ELSE IF(ISTHEP(I).EQ.20) THEN
21139 *         IF(ICOLOR(1,I).EQ.-ICOLD) THEN
21140 *           write(LO,*) ' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
21141 *           ICOLOR(1,I) = -ICNEW
21142 *           RETURN
21143 *         ELSE IF(IDHEP(I).EQ.21) THEN
21144 *           IF(ICOLOR(2,I).EQ.-ICOLD) THEN
21145 *             write(LO,*) ' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
21146 *             ICOLOR(2,I) = -ICNEW
21147 *             RETURN
21148 *           ENDIF
21149 *         ENDIF
21150         ENDIF
21151  100  CONTINUE
21152       END
21153
21154 *$ CREATE PHO_HARREM.FOR
21155 *COPY PHO_HARREM
21156 CDECK  ID>, PHO_HARREM
21157       SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
21158      &                      IUSED,IREJ)
21159 C***********************************************************************
21160 C
21161 C     sample color structure for initial quark/gluon of hard scattering
21162 C     and write hadron remnant to /POEVT1/
21163 C
21164 C     input:    JM1,2   index of mother particle in POEVT1
21165 C               IGEN    mother particle production process
21166 C               IHPOS   hard pomeron number
21167 C               INDXH   index of hard parton
21168 C                       positive for labels 1
21169 C                       negative for labels 2
21170 C               IVAL     1  hard valence parton
21171 C                        0  hard sea parton connected by color flow with
21172 C                           valence quarks
21173 C                       -1  hard sea parton independent off valence
21174 C                           quarks
21175 C               INDXS   index of soft partons needed
21176 C
21177 C     output:   IC1,IC2 color label of initial parton
21178 C               IUSED   number of soft X values used
21179 C               IREJ    rejection flag
21180 C
21181 C**********************************************************************
21182       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21183       SAVE
21184
21185       PARAMETER ( TINY   =  1.D-10 )
21186
21187 C  input/output channels
21188       INTEGER LI,LO
21189       COMMON /POINOU/ LI,LO
21190 C  event debugging information
21191       INTEGER NMAXD
21192       PARAMETER (NMAXD=100)
21193       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21194      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21195       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21196      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21197 C  model switches and parameters
21198       CHARACTER*8 MDLNA
21199       INTEGER ISWMDL,IPAMDL
21200       DOUBLE PRECISION PARMDL
21201       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21202 C  data of c.m. system of Pomeron / Reggeon exchange
21203       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21204       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21205      &                 SIDP,CODP,SIFP,COFP
21206       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21207      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
21208      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
21209 C  obsolete cut-off information
21210       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21211       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21212 C  light-cone x fractions and c.m. momenta of soft cut string ends
21213       INTEGER MAXSOF
21214       PARAMETER ( MAXSOF = 50 )
21215       INTEGER IJSI2,IJSI1
21216       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21217       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21218      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21219      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
21220 C  hard scattering data
21221       INTEGER MSCAHD
21222       PARAMETER ( MSCAHD = 50 )
21223       INTEGER LSCAHD,LSC1HD,LSIDX,
21224      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21225       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21226       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21227      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21228      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21229      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21230      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21231      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21232      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21233
21234 C  standard particle data interface
21235       INTEGER NMXHEP
21236
21237       PARAMETER (NMXHEP=4000)
21238
21239       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21240       DOUBLE PRECISION PHEP,VHEP
21241       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21242      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21243      &                VHEP(4,NMXHEP)
21244 C  extension to standard particle data interface (PHOJET specific)
21245       INTEGER IMPART,IPHIST,ICOLOR
21246       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21247
21248 C  internal rejection counters
21249       INTEGER NMXJ
21250       PARAMETER (NMXJ=60)
21251       CHARACTER*10 REJTIT
21252       INTEGER IFAIL
21253       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21254
21255       IREJ = 0
21256
21257       INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21258
21259       IF(INDXH.GT.0) THEN
21260         IJH = IPHO_CNV1(NINHD(INDXH,1))
21261       ELSE
21262         IJH = IPHO_CNV1(NINHD(-INDXH,2))
21263       ENDIF
21264 C  direct process (photon or pomeron)
21265       IUSED = 0
21266       IC1   = 0
21267       IC2   = 0
21268       IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21269
21270       IHP = 100*ABS(IHPOS)
21271       IVSW = 1
21272 ***************************************
21273 *     IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21274 ***************************************
21275
21276       IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21277      &  'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21278      &  JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21279
21280 C  quark
21281 C****************************************************************
21282
21283         IF(IJH.NE.21) THEN
21284
21285 C  valence quark engaged in hard scattering
21286           IF(IVAL.EQ.1) THEN
21287             CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21288             IF(IREJ.NE.0) THEN
21289               WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21290      &          'invalid valence flavour requested JM,IFLA',JM1,IJH
21291               return
21292             ENDIF
21293             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21294             IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21295      &         .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21296               I = ICA1
21297               ICA1 = ICB1
21298               ICB1 = I
21299             ENDIF
21300 C  remnant of hadron
21301             IF(INDXH.GT.0) THEN
21302               P1 = PSOFT1(1,INDXS)
21303               P2 = PSOFT1(2,INDXS)
21304               P3 = PSOFT1(3,INDXS)
21305               P4 = PSOFT1(4,INDXS)
21306               IJSI1(INDXS) = IREM
21307             ELSE
21308               P1 = PSOFT2(1,INDXS)
21309               P2 = PSOFT2(2,INDXS)
21310               P3 = PSOFT2(3,INDXS)
21311               P4 = PSOFT2(4,INDXS)
21312               IJSI2(INDXS) = IREM
21313             ENDIF
21314 C  registration
21315             CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21316      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21317             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21318      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21319      &        IREM,IPOS,SIGN(INDXS,INDXH)
21320
21321             IUSED = 1
21322
21323 C  sea quark engaged in hard scattering, valence quarks treated
21324           ELSE IF(IVAL.EQ.0) THEN
21325             IF(INDXH.GT.0) THEN
21326               E1 = PSOFT1(4,INDXS)
21327               E2 = PSOFT1(4,INDXS+1)
21328             ELSE
21329               E1 = PSOFT2(4,INDXS)
21330               E2 = PSOFT2(4,INDXS+1)
21331             ENDIF
21332             CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21333             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21334             IF(DT_RNDM(P1).LT.0.5D0) THEN
21335               CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21336             ELSE
21337               CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21338             ENDIF
21339             IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21340      &         .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21341               I = ICA1
21342               ICA1 = ICB1
21343               ICB1 = I
21344             ENDIF
21345             IF(INDXH.GT.0) THEN
21346               P1 = PSOFT1(1,INDXS)
21347               P2 = PSOFT1(2,INDXS)
21348               P3 = PSOFT1(3,INDXS)
21349               P4 = PSOFT1(4,INDXS)
21350               IJSI1(INDXS) = IVFL1
21351             ELSE
21352               P1 = PSOFT2(1,INDXS)
21353               P2 = PSOFT2(2,INDXS)
21354               P3 = PSOFT2(3,INDXS)
21355               P4 = PSOFT2(4,INDXS)
21356               IJSI2(INDXS) = IVFL1
21357             ENDIF
21358 C  registration
21359             CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21360      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21361             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21362      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21363      &        IVFL1,IPOS,SIGN(INDXS,INDXH)
21364
21365 C
21366             IF(INDXH.GT.0) THEN
21367               P1 = PSOFT1(1,INDXS+1)
21368               P2 = PSOFT1(2,INDXS+1)
21369               P3 = PSOFT1(3,INDXS+1)
21370               P4 = PSOFT1(4,INDXS+1)
21371               IJSI1(INDXS+1) = IVFL2
21372             ELSE
21373               P1 = PSOFT2(1,INDXS+1)
21374               P2 = PSOFT2(2,INDXS+1)
21375               P3 = PSOFT2(3,INDXS+1)
21376               P4 = PSOFT2(4,INDXS+1)
21377               IJSI2(INDXS+1) = IVFL2
21378             ENDIF
21379 C  registration
21380             CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21381      &                  IHP,IGEN,ICB1,IVSW,IPOS,1)
21382             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21383      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21384      &        IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21385
21386 C
21387             IF(IJH.LT.0) THEN
21388               ICB1 = ICC2
21389               ICA1 = ICC1
21390             ELSE
21391               ICB1 = ICC1
21392               ICA1 = ICC2
21393             ENDIF
21394             IF(INDXH.GT.0) THEN
21395               P1 = PSOFT1(1,INDXS+2)
21396               P2 = PSOFT1(2,INDXS+2)
21397               P3 = PSOFT1(3,INDXS+2)
21398               P4 = PSOFT1(4,INDXS+2)
21399               IJSI1(INDXS+2) = -IJH
21400             ELSE
21401               P1 = PSOFT2(1,INDXS+2)
21402               P2 = PSOFT2(2,INDXS+2)
21403               P3 = PSOFT2(3,INDXS+2)
21404               P4 = PSOFT2(4,INDXS+2)
21405               IJSI2(INDXS+2) = -IJH
21406             ENDIF
21407 C  registration
21408             CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21409      &                      IHP,IGEN,ICA1,0,IPOS,1)
21410             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21411      &        'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21412      &        -IJH,IPOS,SIGN(INDXS+2,INDXH)
21413             IUSED = 3
21414 C
21415 C  sea quark engaged in hard scattering, valences treated separately
21416           ELSE IF(IVAL.EQ.-1) THEN
21417             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21418             IF(IJH.GT.0) THEN
21419               ICC1 = ICB1
21420               ICB1 = ICA1
21421               ICA1 = ICC1
21422             ENDIF
21423             IF(INDXH.GT.0) THEN
21424               P1 = PSOFT1(1,INDXS)
21425               P2 = PSOFT1(2,INDXS)
21426               P3 = PSOFT1(3,INDXS)
21427               P4 = PSOFT1(4,INDXS)
21428               IJSI1(INDXS) = -IJH
21429             ELSE
21430               P1 = PSOFT2(1,INDXS)
21431               P2 = PSOFT2(2,INDXS)
21432               P3 = PSOFT2(3,INDXS)
21433               P4 = PSOFT2(4,INDXS)
21434               IJSI2(INDXS) = -IJH
21435             ENDIF
21436 C  registration
21437             CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21438      &                      IHP,IGEN,ICA1,0,IPOS,1)
21439             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21440      &        'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21441      &        -IJH,IPOS,SIGN(INDXS,INDXH)
21442
21443             IUSED = 1
21444           ELSE
21445             WRITE(LO,'(1X,A,2I5)')
21446      &        'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21447      &        IVAL,IJH
21448             CALL PHO_ABORT
21449           ENDIF
21450 C
21451           IC1 = ICB1
21452           IC2 = 0
21453 C
21454 C  gluon
21455 C****************************************************************
21456 C
21457 C  gluon from valence quarks
21458         ELSE
21459           IF(IVAL.EQ.1) THEN
21460 C  purely gluonic pomeron remnant
21461             IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21462               IF(INDXH.GT.0) THEN
21463                 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21464                 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21465                 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21466                 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21467                 IJSI1(INDXS) = 0
21468               ELSE
21469                 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21470                 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21471                 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21472                 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21473                 IJSI2(INDXS) = 0
21474               ENDIF
21475               IFL1 = 21
21476               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21477               IF(DT_RNDM(P2).LT.0.5D0) THEN
21478                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21479               ELSE
21480                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21481               ENDIF
21482 C  registration
21483               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21484      &                        IHP,IGEN,ICA1,ICB1,IPOS,1)
21485               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21486      &          'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21487      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21488
21489               IUSED = 2
21490 C  valence quark remnant
21491             ELSE
21492               IF(INDXH.GT.0) THEN
21493                 E1 = PSOFT1(4,INDXS)
21494                 E2 = PSOFT1(4,INDXS+1)
21495               ELSE
21496                 E1 = PSOFT2(4,INDXS)
21497                 E2 = PSOFT2(4,INDXS+1)
21498               ENDIF
21499               CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21500               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21501               IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21502      &           .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21503                 I = ICA1
21504                 ICA1 = ICB1
21505                 ICB1 = I
21506               ENDIF
21507               IF(DT_RNDM(P2).LT.0.5D0) THEN
21508                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21509               ELSE
21510                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21511               ENDIF
21512 C  remnant of hadron
21513               IF(INDXH.GT.0) THEN
21514                 P1 = PSOFT1(1,INDXS)
21515                 P2 = PSOFT1(2,INDXS)
21516                 P3 = PSOFT1(3,INDXS)
21517                 P4 = PSOFT1(4,INDXS)
21518                 IJSI1(INDXS) = IFL1
21519               ELSE
21520                 P1 = PSOFT2(1,INDXS)
21521                 P2 = PSOFT2(2,INDXS)
21522                 P3 = PSOFT2(3,INDXS)
21523                 P4 = PSOFT2(4,INDXS)
21524                 IJSI2(INDXS) = IFL1
21525               ENDIF
21526 C  registration
21527               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21528      &                        IHP,IGEN,ICA1,IVSW,IPOS,1)
21529               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21530      &          'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21531      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21532
21533 C
21534               IF(INDXH.GT.0) THEN
21535                 P1 = PSOFT1(1,INDXS+1)
21536                 P2 = PSOFT1(2,INDXS+1)
21537                 P3 = PSOFT1(3,INDXS+1)
21538                 P4 = PSOFT1(4,INDXS+1)
21539                 IJSI1(INDXS+1) = IFL2
21540               ELSE
21541                 P1 = PSOFT2(1,INDXS+1)
21542                 P2 = PSOFT2(2,INDXS+1)
21543                 P3 = PSOFT2(3,INDXS+1)
21544                 P4 = PSOFT2(4,INDXS+1)
21545                 IJSI2(INDXS+1) = IFL2
21546               ENDIF
21547 C  registration
21548               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21549      &                        IHP,IGEN,ICB1,IVSW,IPOS,1)
21550               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21551      &          'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21552      &          IFL2,IPOS,SIGN(INDXS+1,INDXH)
21553
21554               IUSED = 2
21555             ENDIF
21556 C
21557 C  gluon from sea quarks connected with valence quarks
21558           ELSE IF(IVAL.EQ.0) THEN
21559             IF(INDXH.GT.0) THEN
21560               E1 = PSOFT1(4,INDXS)
21561               E2 = PSOFT1(4,INDXS+1)
21562             ELSE
21563               E1 = PSOFT2(4,INDXS)
21564               E2 = PSOFT2(4,INDXS+1)
21565             ENDIF
21566             CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21567             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21568             IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21569      &         .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21570               I = ICA1
21571               ICA1 = ICB1
21572               ICB1 = I
21573             ENDIF
21574             IF(DT_RNDM(P3).LT.0.5D0) THEN
21575               CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21576             ELSE
21577               CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21578             ENDIF
21579 C  remnant of hadron
21580             IF(INDXH.GT.0) THEN
21581               P1 = PSOFT1(1,INDXS)
21582               P2 = PSOFT1(2,INDXS)
21583               P3 = PSOFT1(3,INDXS)
21584               P4 = PSOFT1(4,INDXS)
21585               IJSI1(INDXS) = IFL1
21586             ELSE
21587               P1 = PSOFT2(1,INDXS)
21588               P2 = PSOFT2(2,INDXS)
21589               P3 = PSOFT2(3,INDXS)
21590               P4 = PSOFT2(4,INDXS)
21591               IJSI2(INDXS) = IFL1
21592             ENDIF
21593 C  registration
21594             CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21595      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21596             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21597      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21598      &        IFL1,IPOS,SIGN(INDXS,INDXH)
21599
21600 C
21601             IF(INDXH.GT.0) THEN
21602               P1 = PSOFT1(1,INDXS+1)
21603               P2 = PSOFT1(2,INDXS+1)
21604               P3 = PSOFT1(3,INDXS+1)
21605               P4 = PSOFT1(4,INDXS+1)
21606               IJSI1(INDXS+1) = IFL2
21607             ELSE
21608               P1 = PSOFT2(1,INDXS+1)
21609               P2 = PSOFT2(2,INDXS+1)
21610               P3 = PSOFT2(3,INDXS+1)
21611               P4 = PSOFT2(4,INDXS+1)
21612               IJSI2(INDXS+1) = IFL2
21613             ENDIF
21614 C  registration
21615             CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21616      &                      IHP,IGEN,ICB1,IVSW,IPOS,1)
21617             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21618      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21619      &        IFL2,IPOS,SIGN(INDXS+1,INDXH)
21620
21621             IF(IPAMDL(18).EQ.0)  THEN
21622 C  sea quark pair
21623               CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21624               IF(ICC1.GT.0) THEN
21625                 IFL1 = ABS(IFL1)
21626                 IFL2 = -IFL1
21627               ELSE
21628                 IFL1 = -ABS(IFL1)
21629                 IFL2 = -IFL1
21630               ENDIF
21631               IF(DT_RNDM(P4).LT.0.5D0) THEN
21632                 ICB1 = ICC2
21633                 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21634               ELSE
21635                 ICA1 = ICC1
21636                 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21637               ENDIF
21638               IF(INDXH.GT.0) THEN
21639                 P1 = PSOFT1(1,INDXS+2)
21640                 P2 = PSOFT1(2,INDXS+2)
21641                 P3 = PSOFT1(3,INDXS+2)
21642                 P4 = PSOFT1(4,INDXS+2)
21643                 IJSI1(INDXS+2) = IFL1
21644               ELSE
21645                 P1 = PSOFT2(1,INDXS+2)
21646                 P2 = PSOFT2(2,INDXS+2)
21647                 P3 = PSOFT2(3,INDXS+2)
21648                 P4 = PSOFT2(4,INDXS+2)
21649                 IJSI2(INDXS+2) = IFL1
21650               ENDIF
21651 C  registration
21652               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21653      &                        IHP,IGEN,ICA1,0,IPOS,1)
21654               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21655      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21656      &          IFL1,IPOS,SIGN(INDXS+2,INDXH)
21657
21658 C
21659               IF(INDXH.GT.0) THEN
21660                 P1 = PSOFT1(1,INDXS+3)
21661                 P2 = PSOFT1(2,INDXS+3)
21662                 P3 = PSOFT1(3,INDXS+3)
21663                 P4 = PSOFT1(4,INDXS+3)
21664                 IJSI1(INDXS+3) = IFL2
21665               ELSE
21666                 P1 = PSOFT2(1,INDXS+3)
21667                 P2 = PSOFT2(2,INDXS+3)
21668                 P3 = PSOFT2(3,INDXS+3)
21669                 P4 = PSOFT2(4,INDXS+3)
21670                 IJSI2(INDXS+3) = IFL2
21671               ENDIF
21672 C  registration
21673               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21674      &                        IHP,IGEN,ICB1,0,IPOS,1)
21675               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21676      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21677      &          IFL2,IPOS,SIGN(INDXS+3,INDXH)
21678
21679               IUSED = 4
21680             ELSE
21681               IUSED = 2
21682             ENDIF
21683 C
21684 C  gluon from independent sea quarks
21685           ELSE IF(IVAL.EQ.-1) THEN
21686             IF(IPAMDL(18).EQ.0) THEN
21687               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21688               CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21689               IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21690      &           .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21691                 I = ICA1
21692                 ICA1 = ICB1
21693                 ICB1 = I
21694               ENDIF
21695               IF(DT_RNDM(P1).LT.0.5D0) THEN
21696                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21697               ELSE
21698                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21699               ENDIF
21700 C  remainder of hadron
21701               IF(INDXH.GT.0) THEN
21702                 P1 = PSOFT1(1,INDXS)
21703                 P2 = PSOFT1(2,INDXS)
21704                 P3 = PSOFT1(3,INDXS)
21705                 P4 = PSOFT1(4,INDXS)
21706                 IJSI1(INDXS) = IFL1
21707               ELSE
21708                 P1 = PSOFT2(1,INDXS)
21709                 P2 = PSOFT2(2,INDXS)
21710                 P3 = PSOFT2(3,INDXS)
21711                 P4 = PSOFT2(4,INDXS)
21712                 IJSI2(INDXS) = IFL1
21713               ENDIF
21714 C  registration
21715               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21716      &                        IHP,IGEN,ICA1,ICA2,IPOS,1)
21717               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21718      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21719      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21720
21721 C  remnant of sea
21722               IF(INDXH.GT.0) THEN
21723                 P1 = PSOFT1(1,INDXS-1)
21724                 P2 = PSOFT1(2,INDXS-1)
21725                 P3 = PSOFT1(3,INDXS-1)
21726                 P4 = PSOFT1(4,INDXS-1)
21727                 IJSI1(INDXS-1) = IFL2
21728               ELSE
21729                 P1 = PSOFT2(1,INDXS-1)
21730                 P2 = PSOFT2(2,INDXS-1)
21731                 P3 = PSOFT2(3,INDXS-1)
21732                 P4 = PSOFT2(4,INDXS-1)
21733                 IJSI2(INDXS-1) = IFL2
21734               ENDIF
21735 C  registration
21736               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21737      &                        IHP,IGEN,ICB1,ICB2,IPOS,1)
21738               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21739      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21740      &          IFL2,IPOS,SIGN(INDXS-1,INDXH)
21741
21742               IUSED = 2
21743             ELSE
21744               CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21745               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21746      &          'PHO_HARREM: no spectator added:(INDXS)',
21747      &          SIGN(INDXS,INDXH)
21748               IUSED = 0
21749             ENDIF
21750 C
21751           ELSE
21752             WRITE(LO,'(1X,A,2I5)')
21753      &        'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21754      &        IVAL,IJH
21755             CALL PHO_ABORT
21756           ENDIF
21757           IC1 = ICC1
21758           IC2 = ICC2
21759         ENDIF
21760       END
21761
21762 *$ CREATE PHO_HARDIR.FOR
21763 *COPY PHO_HARDIR
21764 CDECK  ID>, PHO_HARDIR
21765       SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21766      &                      IREJ)
21767 C**********************************************************************
21768 C
21769 C     parton orientated formulation of direct scattering processes
21770 C
21771 C     input:
21772 C
21773 C     output:   II        particle combination (1..4)
21774 C               IVAL1,2   0 no valence quarks engaged
21775 C                         1 valence quarks engaged
21776 C               MSPAR1,2  number of realized soft partons
21777 C               MHPAR1,2  number of realized hard partons
21778 C               IREJ      1 failure
21779 C                         0 success
21780 C
21781 C**********************************************************************
21782       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21783       SAVE
21784
21785 C  input/output channels
21786       INTEGER LI,LO
21787       COMMON /POINOU/ LI,LO
21788 C  event debugging information
21789       INTEGER NMAXD
21790       PARAMETER (NMAXD=100)
21791       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21792      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21793       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21794      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21795 C  model switches and parameters
21796       CHARACTER*8 MDLNA
21797       INTEGER ISWMDL,IPAMDL
21798       DOUBLE PRECISION PARMDL
21799       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21800 C  hard scattering parameters used for most recent hard interaction
21801       INTEGER NFbeta,NF
21802       DOUBLE PRECISION ALQCD2,BQCD
21803       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21804 C  data of c.m. system of Pomeron / Reggeon exchange
21805       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21806       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21807      &                 SIDP,CODP,SIFP,COFP
21808       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21809      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
21810      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
21811 C  obsolete cut-off information
21812       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21813       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21814 C  hard cross sections and MC selection weights
21815       INTEGER Max_pro_2
21816       PARAMETER ( Max_pro_2 = 16 )
21817       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21818      &  MH_acc_1,MH_acc_2
21819       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21820       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21821      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21822      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21823      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21824      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21825 C  data on most recent hard scattering
21826       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21827       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21828      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21829      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21830       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21831      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21832      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21833      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21834      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21835 C  light-cone x fractions and c.m. momenta of soft cut string ends
21836       INTEGER MAXSOF
21837       PARAMETER ( MAXSOF = 50 )
21838       INTEGER IJSI2,IJSI1
21839       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21840       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21841      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21842      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
21843 C  hard scattering data
21844       INTEGER MSCAHD
21845       PARAMETER ( MSCAHD = 50 )
21846       INTEGER LSCAHD,LSC1HD,LSIDX,
21847      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21848       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21849       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21850      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21851      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21852      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21853      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21854      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21855      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21856 C  internal rejection counters
21857       INTEGER NMXJ
21858       PARAMETER (NMXJ=60)
21859       CHARACTER*10 REJTIT
21860       INTEGER IFAIL
21861       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21862
21863       DIMENSION P1(4),P2(4),PD1(-6:6)
21864
21865       PARAMETER ( TINY   =  1.D-10 )
21866
21867       ITRY  = 0
21868       NTRY  = 10
21869       LSC1HD = 0
21870       LSIDX(1) = 1
21871
21872 C  check phase space
21873       IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21874         IFAIL(18) = IFAIL(18)+1
21875         IREJ = 50
21876         RETURN
21877       ENDIF
21878
21879       AS     = (PARMDL(160+II)/ECMP)**2
21880       AH     = (2.D0*PTWANT/ECMP)**2
21881
21882       ALNS   = LOG(AS)
21883       ALNH   = LOG(AH)
21884
21885       XMAX   = MAX(TINY,1.D0-AS)
21886       Z1MAX  = LOG(XMAX)
21887       Z1DIF  = Z1MAX-ALNH
21888 C
21889 C  main loop to select hard and soft parton kinematics
21890 C -----------------------------------------------------
21891  120  CONTINUE
21892         IREJ = 0
21893         ITRY   = ITRY+1
21894         LSC1HD = LSC1HD+1
21895         IF(ITRY.GT.1) THEN
21896           IFAIL(17) = IFAIL(17)+1
21897           IF(ITRY.GE.NTRY) THEN
21898             IREJ = 1
21899             GOTO 450
21900           ENDIF
21901         ENDIF
21902         LINE   = 0
21903         LSCAHD = 0
21904         XSS1   = 0.D0
21905         XSS2   = 0.D0
21906         MSPAR1 = 0
21907         MSPAR2 = 0
21908
21909 C  select hard V,X
21910         CALL PHO_HARSCA(1,II)
21911         XSS1   = XSS1+X1
21912         XSS2   = XSS2+X2
21913 C  debug output
21914         IF(IDEB(25).GE.20) THEN
21915           WRITE(LO,'(1X,A,2E12.4,2I5)')
21916      &      'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21917      &      AS,XMAX,MSPR,ITRY
21918           WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2  SUM X1,2',
21919      &      X1,X2,XSS1,XSS2
21920         ENDIF
21921
21922       IF(MSPR.LE.11) THEN
21923         IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21924       ELSE IF(MSPR.LE.13) THEN
21925         IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21926       ENDIF
21927
21928 C  fill /POHSLT/
21929       LSCAHD     = 1
21930       LSIDX(1)   = 1
21931       XHD(1,1)   = X1
21932       XHD(1,2)   = X2
21933       X0HD(1,1)  = X1
21934       X0HD(1,2)  = X2
21935       VHD(1)     = V
21936       ETAHD(1,1) = ETAC
21937       ETAHD(1,2) = ETAD
21938       PTHD(1)    = PT
21939       Q2SCA(1,1) = QQPD
21940       Q2SCA(1,2) = QQPD
21941       NPROHD(1)  = MSPR
21942       NBRAHD(1,1)= IDPDG1
21943       NBRAHD(1,2)= IDPDG2
21944       DO 45 I=1,4
21945         PPH(I,1)   = PHI1(I)
21946         PPH(I,2)   = PHI2(I)
21947         PPH(4+I,1) = PHO1(I)
21948         PPH(4+I,2) = PHO2(I)
21949  45   CONTINUE
21950 C  valence quarks
21951       IVAL1 = IV1
21952       IVAL2 = IV2
21953       PDFVA(1,1) = 0.D0
21954       PDFVA(1,2) = 0.D0
21955 C  parton flavours
21956       IF(MSPR.LE.11) THEN
21957         NINHD(1,1) = IDPDG1
21958         NINHD(1,2) = IB
21959         PDFVA(1,2) = PDF2(IB)
21960         KHDIR = 1
21961       ELSE IF(MSPR.LE.13) THEN
21962         NINHD(1,1) = IA
21963         PDFVA(1,1) = PDF1(IA)
21964         NINHD(1,2) = IDPDG2
21965         KHDIR = 2
21966       ELSE
21967         NINHD(1,1) = IDPDG1
21968         NINHD(1,2) = IDPDG2
21969         KHDIR = 3
21970       ENDIF
21971       N0INHD(1,1) = NINHD(1,1)
21972       N0INHD(1,2) = NINHD(1,2)
21973       N0IVAL(1,1) = IVAL1
21974       N0IVAL(1,2) = IVAL2
21975       NOUTHD(1,1) = IC
21976       NOUTHD(1,2) = ID
21977
21978 C  reweight according to photon virtuality
21979       IF(MSPR.NE.14) THEN
21980         IF(IPAMDL(115).GE.1) THEN
21981           WGX = 1.D0
21982           IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21983             QQPD = Q2SCA(1,2)
21984             IF(IPAMDL(115).EQ.1) THEN
21985               IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21986                 WGX = 0.D0
21987               ELSE
21988                 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21989      &               /LOG(QQPD/PARMDL(144))
21990               ENDIF
21991               IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21992             ELSE IF(IPAMDL(115).EQ.2) THEN
21993               CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21994               WGX = PD1(IB)/PDFVA(1,2)
21995             ENDIF
21996           ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21997      &            .AND.(IDPDG1.EQ.22)) THEN
21998             QQPD = Q2SCA(1,1)
21999             IF(IPAMDL(115).EQ.1) THEN
22000               IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
22001                 WGX = 0.D0
22002               ELSE
22003                 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22004      &               /LOG(QQPD/PARMDL(144))
22005               ENDIF
22006               IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
22007             ELSE IF(IPAMDL(115).EQ.2) THEN
22008               CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
22009               WGX = PD1(IA)/PDFVA(1,1)
22010             ENDIF
22011           ENDIF
22012
22013           IF(IDEB(25).GE.25)
22014      &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
22015      &        're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22016      &        KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
22017
22018           IF(WGX.LT.DT_RNDM(WGX)) THEN
22019             IREJ = 50
22020             RETURN
22021           ENDIF
22022
22023           IF(WGX.GT.1.01D0)
22024      &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
22025      &        're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22026      &        KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
22027
22028         ENDIF
22029       ENDIF
22030
22031 C  generate ISR
22032       IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
22033         IF(IPAMDL(109).EQ.1) THEN
22034           Q2H = PARMDL(93)*PT**2
22035         ELSE
22036           Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
22037         ENDIF
22038         XHMAX1 =  1.D0 - XSS1 - AS + XHD(1,1)
22039         XHMAX2 =  1.D0 - XSS2 - AS + XHD(1,2)
22040         DO 42 J=1,4
22041           P1(J) = PPH(4+J,1)
22042           P2(J) = PPH(4+J,2)
22043  42     CONTINUE
22044         CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
22045      &    N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
22046      &    XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
22047         XSS1 = XSS1+XISR1-XHD(1,1)
22048         XSS2 = XSS2+XISR2-XHD(1,2)
22049         NINHD(1,1) = IFL1
22050         NINHD(1,2) = IFL2
22051         XHD(1,1) = XISR1
22052         XHD(1,2) = XISR2
22053       ELSE
22054         IFL1 = NINHD(1,1)
22055         IFL2 = NINHD(1,2)
22056       ENDIF
22057       NIVAL(1,1) = IVAL1
22058       NIVAL(1,2) = IVAL2
22059
22060 C  add photon/hadron remnant
22061
22062 C  incoming gluon
22063       IF(IFL2.EQ.0) THEN
22064         XMAXX    = 1.D0 - XSS2 - AS
22065         XMAXH    = MIN(XMAXX,PARMDL(44))
22066         CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
22067         IVAL2 = 1
22068         MSPAR1 = 0
22069         MSPAR2 = 2
22070         MHPAR1 = 1
22071         MHPAR2 = 1
22072       ELSE IF(IFL1.EQ.0) THEN
22073         XMAXX    = 1.D0 - XSS1 - AS
22074         XMAXH    = MIN(XMAXX,PARMDL(44))
22075         CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
22076         IVAL1 = 1
22077         MSPAR1 = 2
22078         MSPAR2 = 0
22079         MHPAR1 = 1
22080         MHPAR2 = 1
22081
22082 C  incoming quark
22083       ELSE IF(ABS(IFL2).LE.12) THEN
22084         IF(IVAL2.EQ.1) THEN
22085           XS2(1) = 1.D0 - XSS2
22086           MSPAR1 = 0
22087           MSPAR2 = 1
22088           MHPAR1 = 1
22089           MHPAR2 = 1
22090         ELSE
22091           XMAXX    = 1.D0 - XSS2 - AS
22092           XMAXH    = MIN(XMAXX,PARMDL(44))
22093           CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
22094           MSPAR1 = 0
22095           MSPAR2 = 3
22096           MHPAR1 = 1
22097           MHPAR2 = 1
22098         ENDIF
22099       ELSE IF(ABS(IFL1).LE.12) THEN
22100         IF(IVAL1.EQ.1) THEN
22101           XS1(1) = 1.D0 - XSS1
22102           MSPAR1 = 1
22103           MSPAR2 = 0
22104           MHPAR1 = 1
22105           MHPAR2 = 1
22106         ELSE
22107           XMAXX    = 1.D0 - XSS1 - AS
22108           XMAXH    = MIN(XMAXX,PARMDL(44))
22109           CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
22110           MSPAR1 = 3
22111           MSPAR2 = 0
22112           MHPAR1 = 1
22113           MHPAR2 = 1
22114         ENDIF
22115
22116 C  double direct process
22117       ELSE IF(MSPR.EQ.14) THEN
22118         MSPAR1 = 0
22119         MSPAR2 = 0
22120         MHPAR1 = 1
22121         MHPAR2 = 1
22122
22123 C  unknown process
22124       ELSE
22125         WRITE(LO,'(/1X,A,I3/)')
22126      &    'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
22127         CALL PHO_ABORT
22128       ENDIF
22129
22130       IF(IREJ.NE.0) THEN
22131         IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
22132      &    'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
22133         GOTO 120
22134       ENDIF
22135
22136 C  soft particle momenta
22137       IF(MSPAR1.GT.0) THEN
22138         DO 50 I=1,MSPAR1
22139           PSOFT1(1,I) = 0.D0
22140           PSOFT1(2,I) = 0.D0
22141           PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22142           PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22143  50     CONTINUE
22144       ENDIF
22145       IF(MSPAR2.GT.0) THEN
22146         DO 55 I=1,MSPAR2
22147           PSOFT2(1,I) = 0.D0
22148           PSOFT2(2,I) = 0.D0
22149           PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22150           PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22151  55     CONTINUE
22152       ENDIF
22153 C  process counting
22154       MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
22155       KSOFT = MAX(MSPAR1,MSPAR2)
22156       KHARD = MAX(MHPAR1,MHPAR2)
22157 C  debug output
22158       IF(IDEB(25).GE.10) THEN
22159         WRITE(LO,'(/1X,A,2I3,3I5)')
22160      &    'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
22161      &     IVAL1,IVAL2,MSPR,ITRY,NTRY
22162         IF(MSPAR1.GT.0) THEN
22163           WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
22164           DO 105 I=1,MSPAR1
22165             WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
22166  105      CONTINUE
22167         ENDIF
22168         IF(MSPAR2.GT.0) THEN
22169           WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
22170           DO 106 I=1,MSPAR2
22171             WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
22172  106      CONTINUE
22173         ENDIF
22174         WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
22175         WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
22176         WRITE(LO,'(5X,A,I4)') 'fin.hard momenta  particle 1:',MHPAR1
22177         WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
22178         WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
22179         WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
22180         WRITE(LO,'(5X,A,I4)') 'fin.hard momenta  particle 2:',MHPAR2
22181         WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
22182       ENDIF
22183       RETURN
22184
22185  450  CONTINUE
22186       IFAIL(16) = IFAIL(16)+1
22187       IF(IDEB(25).GE.2) THEN
22188         WRITE(LO,'(1X,A,3I5)')
22189      &    'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
22190        WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
22191        IF(IDEB(25).GE.5) THEN
22192          CALL PHO_PREVNT(0)
22193        ELSE
22194          CALL PHO_PREVNT(-1)
22195        ENDIF
22196       ENDIF
22197
22198       END
22199
22200 *$ CREATE PHO_POMSCA.FOR
22201 *COPY PHO_POMSCA
22202 CDECK  ID>, PHO_POMSCA
22203       SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
22204      &                     MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
22205 C**********************************************************************
22206 C
22207 C     parton orientated formulation of soft and hard inelastic events
22208 C
22209 C
22210 C     input:    II        particle combiantion (1..4)
22211 C               MSPOM     number of soft pomerons
22212 C               MHPOM     number of semihard pomerons
22213 C               MSREG     number of soft reggeons
22214 C
22215 C     output:   IVAL1,2   0 no valence quark engaged
22216 C                         otherwise:  position of valence quark engaged
22217 C                         neg.number: gluon connected to valence quark
22218 C                                     by color flow
22219 C               MSPAR1,2  number of realized soft partons
22220 C               MHPAR1,2  number of realized hard partons
22221 C               IREJ      1 failure
22222 C                         0 success
22223 C
22224 C**********************************************************************
22225       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22226       SAVE
22227
22228       PARAMETER (TINY   =  1.D-30 )
22229
22230 C  input/output channels
22231       INTEGER LI,LO
22232       COMMON /POINOU/ LI,LO
22233 C  event debugging information
22234       INTEGER NMAXD
22235       PARAMETER (NMAXD=100)
22236       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22237      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22238       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22239      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22240 C  model switches and parameters
22241       CHARACTER*8 MDLNA
22242       INTEGER ISWMDL,IPAMDL
22243       DOUBLE PRECISION PARMDL
22244       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22245 C  general process information
22246       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22247       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22248 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
22249       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22250       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22251       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22252      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22253 C  event weights and generated cross section
22254       INTEGER IPOWGC,ISWCUT,IVWGHT
22255       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22256       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22257      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22258 C  hard cross sections and MC selection weights
22259       INTEGER Max_pro_2
22260       PARAMETER ( Max_pro_2 = 16 )
22261       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22262      &  MH_acc_1,MH_acc_2
22263       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22264       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22265      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22266      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22267      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22268      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22269 C  hard scattering parameters used for most recent hard interaction
22270       INTEGER NFbeta,NF
22271       DOUBLE PRECISION ALQCD2,BQCD
22272       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22273 C  data of c.m. system of Pomeron / Reggeon exchange
22274       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22275       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22276      &                 SIDP,CODP,SIFP,COFP
22277       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22278      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
22279      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
22280 C  obsolete cut-off information
22281       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22282       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22283 C  some hadron information, will be deleted in future versions
22284       INTEGER NFS
22285       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22286       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22287 C  data on most recent hard scattering
22288       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22289       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22290      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22291      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22292       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22293      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22294      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22295      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22296      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22297 C  light-cone x fractions and c.m. momenta of soft cut string ends
22298       INTEGER MAXSOF
22299       PARAMETER ( MAXSOF = 50 )
22300       INTEGER IJSI2,IJSI1
22301       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22302       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22303      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22304      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
22305 C  hard scattering data
22306       INTEGER MSCAHD
22307       PARAMETER ( MSCAHD = 50 )
22308       INTEGER LSCAHD,LSC1HD,LSIDX,
22309      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22310       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22311       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22312      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22313      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22314      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22315      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22316      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22317      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22318 C  table of particle indices for recursive PHOJET calls
22319       INTEGER MAXIPX
22320       PARAMETER ( MAXIPX = 100 )
22321       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22322       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22323      &                IPOIX1,IPOIX2,IPOIX3
22324 C  internal rejection counters
22325       INTEGER NMXJ
22326       PARAMETER (NMXJ=60)
22327       CHARACTER*10 REJTIT
22328       INTEGER IFAIL
22329       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22330
22331       DIMENSION P1(4),P2(4),PD1(-6:6)
22332
22333       IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22334      &  'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22335
22336       ITRY  = 0
22337       NTRY  = 10
22338       IREJ  = 0
22339       INMAX = 10
22340       MHARD = MHPOM
22341
22342 C  phase space limitation (single hard valence-valence quark scattering)
22343       IF(MHPOM.GT.0) THEN
22344         Emin = 2.D0*PTWANT + 0.2D0
22345         IF(ECMP.LT.Emin) THEN
22346           IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22347      &      'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22348           IREJ = 50
22349           IFAIL(6) = IFAIL(6) + 1
22350           RETURN
22351         ENDIF
22352       ENDIF
22353
22354       SAS    = PARMDL(160+II)/ECMP
22355       SAH    = 2.D0*PTWANT/ECMP
22356       AS     = SAS**2
22357       AH     = SAH**2
22358
22359 C  save energy for leading particle effect
22360       XMAXP1 = 1.D0
22361       if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22362       XMAXP2 = 1.D0
22363       if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22364
22365 C
22366 C  main loop to select hard and soft parton kinematics
22367 C -----------------------------------------------------
22368       IFAIL(31) = IFAIL(31)+MHARD
22369  20   CONTINUE
22370         IREJ  = 0
22371         IHARD = 0
22372         LSC1HD = 0
22373         ITRY  = ITRY+1
22374         IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22375         IF(ITRY.GE.NTRY) THEN
22376           IREJ = 1
22377           GOTO 450
22378         ENDIF
22379         LINE   = 0
22380         LSCAHD = 0
22381         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22382           XSS1   = MAX(0.D0,1.D0-XPSUB)
22383           XSS2   = MAX(0.D0,1.D0-XTSUB)
22384         ELSE
22385           XSS1   = 0.D0
22386           XSS2   = 0.D0
22387         ENDIF
22388  22     continue
22389
22390 C  partons needed to construct soft/hard interactions
22391         MSPAR1 = 2*MSPOM+MSREG+MHPOM
22392         MSPAR2 = MSPAR1
22393         MHPAR1 = MHPOM
22394         MHPAR2 = MHPOM
22395
22396 C  number of strings
22397         MSCHA = 2*MSPOM+MSREG
22398         MHCHA = 2*MHPOM
22399
22400         KSOFT = MSCHA
22401         KHARD = MHCHA
22402
22403 C  check actual phase space limit
22404         XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22405         IF(XX.GE.1.D0) THEN
22406           IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22407      &      'PHO_POMSCA: internal kin. rejection ',
22408      &      '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22409      &      MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22410           if(MSPOM+MSREG+MHPOM.gt.1) then
22411             if(MSREG.gt.0) then
22412               MSREG = MSREG-1
22413             else if(MSPOM.gt.0) THEN
22414               MSPOM = MSPOM-1
22415             else if(MHPOM.gt.1) then
22416               MHPOM = MHPOM-1
22417             endif
22418             goto 22
22419           endif
22420           IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22421      &      'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22422           IREJ = 50
22423           IFAIL(6) = IFAIL(6) + 1
22424           RETURN
22425         ENDIF
22426
22427         XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22428         XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22429
22430 C  very low energy phase space restriction
22431         if(MHARD.gt.0) then
22432           if((XMAXX1*XMAXX2.le.AH)) then
22433             IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22434      &        'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22435             IREJ = 50
22436             IFAIL(6) = IFAIL(6) + 1
22437             RETURN
22438           endif
22439         endif
22440
22441         AS = MAX(AS,PSOMIN/PCMP)
22442         ALNS  = LOG(AS)
22443         ALNH  = LOG(AH)
22444         Z1MAX = LOG(XMAXX1)
22445         Z2MAX = LOG(XMAXX2)
22446         Z1DIF = Z1MAX+Z2MAX-ALNH
22447         Z2DIF = Z1DIF
22448         PTMAX = 0.D0
22449 C
22450 C  select hard parton momenta
22451 C ------------------- begin of inner loop -------------------
22452         IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22453
22454         IF(MHARD.GT.MSCAHD) THEN
22455           WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22456      &      'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22457           IREJ = 1
22458           RETURN
22459         ENDIF
22460
22461         DO 11 NN=1,MHARD
22462 C
22463 C  generate one resolved hard scattering
22464 C
22465 C  high-pt option
22466           IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22467             CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22468      &                  -1,Max_pro_2,1,4,MSPOM+MHPOM)
22469             XSCUT = HSig(9)
22470             AHS    = AH
22471             ALNHS  = ALNH
22472             Z1DIFS = Z1DIF
22473             Z2DIFS = Z2DIF
22474             AH    = (2.D0*PTWANT/ECMP)**2
22475             ALNH  = LOG(AH)
22476             Z1DIF = Z1MAX+Z2MAX-ALNH
22477             Z2DIF = Z1DIF
22478             IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22479               IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22480      &          'PHO_POMSCA: kin.rejection, high-pt option ',
22481      &          '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22482               IREJ = 5
22483               RETURN
22484             ENDIF
22485             CALL PHO_HARSCA(2,II)
22486             CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22487      &                  -1,Max_pro_2,1,4,MSPOM+MHPOM)
22488             AH    = AHS
22489             ALNH  = ALNHS
22490             Z1DIF = Z1DIFS
22491             Z2DIF = Z2DIFS
22492             IPOWGC(4+II) = IPOWGC(4+II)+1
22493             HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22494 C  minimum bias option
22495           ELSE
22496             CALL PHO_HARSCA(2,II)
22497           ENDIF
22498
22499 C  fill /POHSLT/
22500           LSIDX(NN)    = NN
22501           LSCAHD       = NN
22502           XHD(NN,1)    = X1
22503           XHD(NN,2)    = X2
22504           X0HD(NN,1)   = X1
22505           X0HD(NN,2)   = X2
22506           VHD(NN)      = V
22507           ETAHD(NN,1)  = ETAC
22508           ETAHD(NN,2)  = ETAD
22509           PTHD(NN)     = PT
22510           NPROHD(NN)   = MSPR
22511           Q2SCA(NN,1)  = QQPD
22512           Q2SCA(NN,2)  = QQPD
22513           PDFVA(NN,1)  = PDF1(IA)
22514           PDFVA(NN,2)  = PDF2(IB)
22515           NINHD(NN,1)  = IA
22516           NINHD(NN,2)  = IB
22517           N0INHD(NN,1) = IA
22518           N0INHD(NN,2) = IB
22519           NIVAL(NN,1)  = IV1
22520           NIVAL(NN,2)  = IV2
22521           N0IVAL(NN,1) = IV1
22522           N0IVAL(NN,2) = IV2
22523           NOUTHD(NN,1) = IC
22524           NOUTHD(NN,2) = ID
22525           NBRAHD(NN,1) = IDPDG1
22526           NBRAHD(NN,2) = IDPDG2
22527           I3 = 8*(NN-1)
22528           I4 = 8*(NN-1)+4
22529           DO 50 I=1,4
22530             PPH(I3+I,1) = PHI1(I)
22531             PPH(I3+I,2) = PHI2(I)
22532             PPH(I4+I,1) = PHO1(I)
22533             PPH(I4+I,2) = PHO2(I)
22534  50       CONTINUE
22535
22536  11     CONTINUE
22537
22538 C  sort according to pt-hat
22539         DO 12 NN=1,MHARD
22540           PTMX = PTHD(LSIDX(NN))
22541           IPTM = NN
22542           DO 13 I=NN+1,MHARD
22543             IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22544               IPTM = I
22545               PTMX = PTHD(LSIDX(I))
22546             ENDIF
22547  13       CONTINUE
22548           IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22549  12     CONTINUE
22550         IPTM = LSIDX(1)
22551
22552 C  copy partons, generate ISR
22553         DO 15 L=1,MHARD
22554           NN = LSIDX(L)
22555           XSSS1  = XSS1+XHD(NN,1)
22556           XSSS2  = XSS2+XHD(NN,2)
22557 C  debug output
22558           IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22559      &      'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22560      &      L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22561 C  check phase space
22562           IF(    (XSSS1.GT.XMAXX1)
22563      &       .OR.(XSSS2.GT.XMAXX2)
22564      &       .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22565             IF(IHARD.EQ.0) THEN
22566               IF(ISWMDL(2).NE.1) GOTO 20
22567               MHPOM = 0
22568               MSPOM = 1
22569               MSREG = 0
22570             ENDIF
22571             GOTO 199
22572           ENDIF
22573
22574 C  reweight according to photon virtuality
22575           IF(IPAMDL(115).GE.1) THEN
22576             QQPD = Q2SCA(NN,1)
22577             WGX = 1.D0
22578             IF(IDPDG1.EQ.22) THEN
22579               IF(IPAMDL(115).EQ.1) THEN
22580                 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22581                   WG1 = 0.D0
22582                 ELSE
22583                   WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22584      &                 /LOG(QQPD/PARMDL(144))
22585                 ENDIF
22586                 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22587               ELSE IF(IPAMDL(115).EQ.2) THEN
22588                 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22589                 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22590               ENDIF
22591               WGX = WG1
22592             ENDIF
22593             QQPD = Q2SCA(NN,2)
22594             IF(IDPDG2.EQ.22) THEN
22595               IF(IPAMDL(115).EQ.1) THEN
22596                 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22597                   WG1 = 0.D0
22598                 ELSE
22599                   WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22600      &                 /LOG(QQPD/PARMDL(144))
22601                 ENDIF
22602                 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22603               ELSE IF(IPAMDL(115).EQ.2) THEN
22604                 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22605                 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22606               ENDIF
22607               WGX = WGX*WG1
22608             ENDIF
22609
22610             IF(IDEB(24).GE.25)
22611      &        WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22612      &          ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22613      &          KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22614
22615             IF(WGX.LT.DT_RNDM(WGX)) THEN
22616               IF(L.EQ.1) THEN
22617                 IREJ = 50
22618                 RETURN
22619               ELSE
22620                 GOTO 199
22621               ENDIF
22622             ENDIF
22623
22624             IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22625      &        'PHO_POMSCA: ',
22626      &        'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22627      &        KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22628
22629           ENDIF
22630
22631 C  generate ISR
22632           IF((ISWMDL(8).GE.2)
22633      &       .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22634             IF(IPAMDL(109).EQ.1) THEN
22635               Q2H = PARMDL(93)*PTHD(NN)**2
22636             ELSE
22637               Q2H = -PARMDL(93)*VHD(NN)
22638      &              *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22639             ENDIF
22640             XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22641             XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22642             I3     = 8*NN-4
22643             DO 42 J=1,4
22644               P1(J) = PPH(I3+J,1)
22645               P2(J) = PPH(I3+J,2)
22646  42         CONTINUE
22647             IF(IDEB(24).GE.10)
22648      &        WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22649      &          'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22650      &          L,NN,XHD(NN,1),XHD(NN,2),Q2H
22651             J = NN
22652             IF(L.EQ.1) J = -NN
22653             CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22654      &        N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22655      &        X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22656      &        NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22657             XSSS1 = XSSS1+XISR1-XHD(NN,1)
22658             XSSS2 = XSSS2+XISR2-XHD(NN,2)
22659             NINHD(NN,1) = IFL1
22660             NINHD(NN,2) = IFL2
22661             XHD(NN,1) = XISR1
22662             XHD(NN,2) = XISR2
22663           ENDIF
22664
22665 C  check phase space
22666           IF(    (XSSS1.GT.XMAXX1)
22667      &       .OR.(XSSS2.GT.XMAXX2)
22668      &       .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22669             IF(IHARD.EQ.0) THEN
22670               IF(ISWMDL(2).NE.1) GOTO 20
22671               MHPOM = 0
22672               MSPOM = 1
22673               MSREG = 0
22674             ENDIF
22675             GOTO 199
22676           ENDIF
22677
22678 C  leave energy for leading particle effect
22679           IF((IHARD.GT.0).AND.
22680      &       ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22681             GOTO 199
22682           endif
22683
22684 C  hard scattering accepted
22685           IHARD = IHARD+1
22686           XSS1 = XSSS1
22687           XSS2 = XSSS2
22688           IFAIL(31) = IFAIL(31)-1
22689
22690  15     CONTINUE
22691
22692 C ------------------- end of inner (hard) loop -------------------
22693  199    CONTINUE
22694
22695         MHPOM =  IHARD
22696         MHPAR1 = IHARD
22697         MHPAR2 = IHARD
22698
22699 C  count valences involved in hard scattering
22700         IVAL1  = 0
22701         IVAL2  = 0
22702         DO 17 L=1,IHARD
22703           NN = LSIDX(L)
22704           IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22705           IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22706  17     CONTINUE
22707
22708         IQUA1  = 0
22709         IQUA2  = 0
22710         IVGLU1 = 0
22711         IVGLU2 = 0
22712         DO 18 L=1,IHARD
22713           NN = LSIDX(L)
22714
22715 C  photon, pomeron valences
22716           IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22717             IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22718               NIVAL(NN,1) = 1
22719               IVAL1 = NN
22720             ENDIF
22721           ENDIF
22722           IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22723             IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22724               NIVAL(NN,2) = 1
22725               IVAL2 = NN
22726             ENDIF
22727           ENDIF
22728
22729 C  total number of quarks
22730           IF(NINHD(NN,1).NE.0) THEN
22731             IQUA1 = IQUA1+1
22732           ELSE IF(IVGLU1.EQ.0) THEN
22733             IVGLU1 = NN
22734           ENDIF
22735           IF(NINHD(NN,2).NE.0) THEN
22736             IQUA2 = IQUA2+1
22737           ELSE IF(IVGLU2.EQ.0) THEN
22738             IVGLU2 = NN
22739           ENDIF
22740  18     CONTINUE
22741
22742 C  gluons emitted by valence quarks
22743         VALPRO = 1.D0
22744         IF(II.EQ.1) VALPRO = VALPRG(1)
22745         IVQ1 = 1
22746         IVG1 = 0
22747         IVAL1 = MAX(IVAL1,0)
22748         IF(IVAL1.EQ.0) THEN
22749           IVQ1 = 0
22750           IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22751             IVAL1 = -IVGLU1
22752             IVG1 = 1
22753           ENDIF
22754         ENDIF
22755         VALPRO = 1.D0
22756         IF(II.EQ.1) VALPRO = VALPRG(2)
22757         IVQ2 = 1
22758         IVG2 = 0
22759         IVAL2 = MAX(IVAL2,0)
22760         IF(IVAL2.EQ.0) THEN
22761           IVQ2 = 0
22762           IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22763             IVAL2 = -IVGLU2
22764             IVG2 = 1
22765           ENDIF
22766         ENDIF
22767         MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22768 C  debug output
22769         IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22770      &    'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22771      &    IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22772
22773 C  select soft X values
22774  25     CONTINUE
22775 C  number of soft/remnant quarks
22776         IF(MSPOM.EQ.0) THEN
22777           IF(IPAMDL(18).EQ.0) THEN
22778             MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22779             MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22780           ELSE
22781             MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22782             MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22783           ENDIF
22784         ELSE
22785           IF(IPAMDL(18).EQ.0) THEN
22786             MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22787             MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22788           ELSE
22789             MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22790             MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22791           ENDIF
22792         ENDIF
22793 C  debug output
22794         IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22795      &    'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22796      &    MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22797
22798         XMAX1  = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22799         XMAX2  = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22800         I1 = IVQ1
22801         I2 = IVQ2
22802         IF(IVAL1.LE.0) I1 = 0
22803         IF(IVAL2.LE.0) I2 = 0
22804         IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22805           MSDIFF = 2*MSPOM
22806         ELSE
22807           MSDIFF = 2*MAX(0,MSPOM-1)
22808         ENDIF
22809         MSG1 = MSPAR1
22810         MSG2 = MSPAR2
22811         MSM1 = MSPAR1-MSDIFF
22812         MSM2 = MSPAR2-MSDIFF
22813         XMAXH1 = MIN(XMAX1,PARMDL(44))
22814         XMAXH2 = MIN(XMAX2,PARMDL(44))
22815         CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22816      &              XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22817
22818 C  correct for proper simulation of high pt tail
22819         IF(IREJ.NE.0) THEN
22820           IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22821      &      'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22822      &      MSPOM,MHPOM,I1,I2
22823           IF(MSPOM*MHPOM.GT.0) THEN
22824             MSPOM = MSPOM-1
22825             GOTO 25
22826           ELSE IF(MSPOM.GT.1) THEN
22827             MSPOM = MSPOM-1
22828             GOTO 25
22829           ELSE IF(MHPOM.GT.1) THEN
22830             IHARD = IHARD-1
22831             IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22832      &         .AND.(IPROCE.EQ.1)) THEN
22833               XSS1   = MAX(0.D0,1.D0-XPSUB)
22834               XSS2   = MAX(0.D0,1.D0-XTSUB)
22835             ELSE
22836               XSS1   = 0.D0
22837               XSS2   = 0.D0
22838             ENDIF
22839             DO 103 K=1,IHARD
22840               I = LSIDX(K)
22841               XSS1 = XSS1+ XHD(I,1)
22842               XSS2 = XSS2+ XHD(I,2)
22843  103        CONTINUE
22844             GOTO 199
22845           ENDIF
22846           IREJ = 4
22847           GOTO 450
22848         ENDIF
22849 C  accepted
22850         MSPOM  = MSPOM-(MSPAR1-MSG1)/2
22851         MSPAR1 = MSG1
22852         MSPAR2 = MSG2
22853 C  ------------ kinematics sampled ---------------
22854 C  debug output
22855         IF(IDEB(24).GE.10) THEN
22856           WRITE(LO,'(1X,A,I3)')
22857      &      'PHO_POMSCA: soft x values, ITRY',ITRY
22858           DO 104 I=2,MAX(MSPAR1,MSPAR2)
22859             WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22860  104      CONTINUE
22861         ENDIF
22862       IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22863
22864 C  end of loop
22865       XS1(1) = 1.D0 - XSS1
22866       XS2(1) = 1.D0 - XSS2
22867
22868 C  process counting
22869       DO 30 N=1,LSCAHD
22870         MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22871  30   CONTINUE
22872
22873 C  soft particle momenta
22874
22875       IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22876         WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22877      &    '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22878         IREJ = 1
22879         RETURN
22880       ENDIF
22881
22882       DO 55 I=1,MSPAR1
22883         PSOFT1(1,I) = 0.D0
22884         PSOFT1(2,I) = 0.D0
22885         PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22886         PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22887  55   CONTINUE
22888       DO 60 I=1,MSPAR2
22889         PSOFT2(1,I) = 0.D0
22890         PSOFT2(2,I) = 0.D0
22891         PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22892         PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22893  60   CONTINUE
22894
22895       KSOFT = MAX(MSPAR1,MSPAR2)
22896       KHARD = MAX(MHPAR1,MHPAR2)
22897       KSPOM = MSPOM
22898       KSREG = MSREG
22899       KHPOM = MHPOM
22900
22901 C  debug output
22902       IF(IDEB(24).GE.10) THEN
22903         WRITE(LO,'(/1X,A,2I3,2I5)')
22904      &    'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22905      &     IVAL1,IVAL2,ITRY,NTRY
22906         IF(MSPAR1+MSPAR2.GT.0) THEN
22907           WRITE(LO,'(5X,A)') 'soft x particle1   particle2:'
22908           XTMP1 = 0.D0
22909           XTMP2 = 0.D0
22910           DO 105 I=1,MAX(MSPAR1,MSPAR2)
22911             IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22912               WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22913               XTMP1 = XTMP1+XS1(I)
22914               XTMP2 = XTMP2+XS2(I)
22915             ELSE IF(I.LE.MSPAR1) THEN
22916               WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22917               XTMP1 = XTMP1+XS1(I)
22918             ELSE IF(I.LE.MSPAR2) THEN
22919               WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22920               XTMP2 = XTMP2+XS2(I)
22921             ENDIF
22922  105      CONTINUE
22923           WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22924         ENDIF
22925         IF(MHPAR1.GT.0) THEN
22926           WRITE(LO,'(5X,A)')
22927      &      'NR  IDX  MSPR hard X / hard X ISR / flavor particle 1,2:'
22928           DO 107 K=1,MHPAR1
22929             I = LSIDX(K)
22930             WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22931      &        K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22932      &        NINHD(I,1),NINHD(I,2)
22933               XTMP1 = XTMP1+XHD(I,1)
22934               XTMP2 = XTMP2+XHD(I,2)
22935  107      CONTINUE
22936           WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22937           WRITE(LO,'(5X,A)') 'hard momenta  particle1:'
22938           DO 108 K=1,MHPAR1
22939             I = LSIDX(K)
22940             I3 = 8*I-4
22941             WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22942      &        NOUTHD(I,1)
22943  108      CONTINUE
22944           WRITE(LO,'(5X,A)') 'hard momenta  particle2:'
22945           DO 110 K=1,MHPAR2
22946             I = LSIDX(K)
22947             I3 = 8*I-4
22948             WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22949      &        NOUTHD(I,2)
22950  110      CONTINUE
22951         ENDIF
22952       ENDIF
22953       RETURN
22954
22955 C  event rejected, print debug information
22956  450  CONTINUE
22957       IFAIL(4) = IFAIL(4)+1
22958       IF(IDEB(24).GE.2) THEN
22959         WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22960      &    'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22961      &    MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22962         WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22963         IF(IDEB(24).GE.5) THEN
22964           CALL PHO_PREVNT(0)
22965         ELSE
22966           CALL PHO_PREVNT(-1)
22967         ENDIF
22968       ENDIF
22969
22970       END
22971
22972 *$ CREATE PHO_HARX12.FOR
22973 *COPY PHO_HARX12
22974 CDECK  ID>, PHO_HARX12
22975       SUBROUTINE PHO_HARX12
22976 C**********************************************************************
22977 C
22978 C     selection of x1 and x2 according to 1/x1*1/x2
22979 C
22980 C**********************************************************************
22981       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22982       SAVE
22983
22984       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22985
22986 C  input/output channels
22987       INTEGER LI,LO
22988       COMMON /POINOU/ LI,LO
22989 C  data on most recent hard scattering
22990       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22991       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22992      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22993      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22994       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22995      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22996      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22997      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22998      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22999
23000 10    CONTINUE
23001         Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
23002         Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
23003         IF ( (Z1+Z2).LT.ALNH ) GOTO 10
23004       X1   = EXP(Z1)
23005       X2   = EXP(Z2)
23006       AXX  = AH/(X1*X2)
23007       W    = SQRT(MAX(TINY,1.D0-AXX))
23008       W1   = AXX/(1.D0+W)
23009
23010       END
23011
23012 *$ CREATE PHO_HARDX1.FOR
23013 *COPY PHO_HARDX1
23014 CDECK  ID>, PHO_HARDX1
23015       SUBROUTINE PHO_HARDX1
23016 C**********************************************************************
23017 C
23018 C     selection of x1 according to 1/x1
23019 C     ( x2 = 1 )
23020 C
23021 C**********************************************************************
23022       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23023       SAVE
23024
23025       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23026
23027 C  input/output channels
23028       INTEGER LI,LO
23029       COMMON /POINOU/ LI,LO
23030 C  data on most recent hard scattering
23031       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23032       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23033      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23034      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23035       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23036      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23037      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23038      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23039      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23040
23041       Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
23042       X2   = 1.D0
23043       X1   = EXP(Z1)
23044       AXX  = AH/X1
23045       W    = SQRT(MAX(TINY,1.D0-AXX))
23046       W1   = AXX/(1.D0+W)
23047
23048       END
23049
23050 *$ CREATE PHO_HARKIN.FOR
23051 *COPY PHO_HARKIN
23052 CDECK  ID>, PHO_HARKIN
23053       SUBROUTINE PHO_HARKIN(IREJ)
23054 C***********************************************************************
23055 C
23056 C     selection of kinematic variables
23057 C     (resolved and direct processes)
23058 C
23059 C***********************************************************************
23060       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23061       SAVE
23062
23063       PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
23064
23065 C  input/output channels
23066       INTEGER LI,LO
23067       COMMON /POINOU/ LI,LO
23068 C  event debugging information
23069       INTEGER NMAXD
23070       PARAMETER (NMAXD=100)
23071       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23072      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23073       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23074      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23075 C  data of c.m. system of Pomeron / Reggeon exchange
23076       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23077       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23078      &                 SIDP,CODP,SIFP,COFP
23079       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23080      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23081      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23082 C  data on most recent hard scattering
23083       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23084       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23085      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23086      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23087       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23088      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23089      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23090      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23091      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23092 C  internal cross check information on hard scattering limits
23093       DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
23094       COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
23095
23096       PARAMETER ( Max_pro_2 = 16 )
23097       DIMENSION RM(-1:Max_pro_2)
23098       DATA RM / 3.31D0, 0.0D0,
23099      &          7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
23100      &          0.45D0, 0.89D0, 0.89D0, 0.0D0,  4.776D0,
23101      &          0.615D0,4.776D0,0.615D0,1.0D0,  0.0D0,
23102      &          1.0D0 /
23103
23104       IREJ = 0
23105       M    = MSPR
23106
23107 C------------- resolved processes -----------
23108       IF     ( M.EQ.1 ) THEN
23109 10      CALL PHO_HARX12
23110         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23111         U  =-1.D0-V
23112         R  = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
23113         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23114      &    'PHO_HARKIN:weight error',M
23115         IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
23116         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23117       ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
23118 20      CALL PHO_HARX12
23119         WL = LOG(W1)
23120         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23121         U  =-1.D0-V
23122         R  = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
23123         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23124      &    'PHO_HARKIN:weight error',M
23125         IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
23126         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23127       ELSEIF ( M.EQ.3 ) THEN
23128 30      CALL PHO_HARX12
23129         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23130         U  =-1.D0-V
23131         R  = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
23132         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23133      &    'PHO_HARKIN:weight error',M
23134         IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
23135       ELSEIF ( M.EQ.5 ) THEN
23136 50      CALL PHO_HARX12
23137         V  =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
23138         U  =-1.D0-V
23139         R  = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
23140         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23141      &    'PHO_HARKIN:weight error',M
23142         IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
23143       ELSEIF ( M.EQ.6 ) THEN
23144 60      CALL PHO_HARX12
23145         V  =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
23146         U  =-1.D0-V
23147         R  = (4.D0/9.D0)*(U*U+V*V)*AXX
23148         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23149      &    'PHO_HARKIN:weight error',M
23150         IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
23151       ELSEIF ( M.EQ.7 ) THEN
23152 70      CALL PHO_HARX12
23153         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23154         U  =-1.D0-V
23155         R  = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
23156      &       -(4.D0/27.D0)*V/U)
23157         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23158      &    'PHO_HARKIN:weight error',M
23159         IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
23160         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23161       ELSEIF ( M.EQ.8 ) THEN
23162 80      CALL PHO_HARX12
23163         V  =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
23164         U  =-1.D0-V
23165         R  = (4.D0/9.D0)*(1.D0+U*U)
23166         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23167      &    'PHO_HARKIN:weight error',M
23168         IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
23169       ELSEIF ( M.EQ.-1 ) THEN
23170 90      CALL PHO_HARX12
23171         WL = LOG(W1)
23172         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23173         U  =-1.D0-V
23174         R  = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
23175         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23176      &    'PHO_HARKIN:weight error',M
23177         IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
23178 C------------- direct / single-resolved processes -----------
23179       ELSEIF ( M.EQ.10 ) THEN
23180 100     CALL PHO_HARDX1
23181         WL = LOG(AXX/(1.D0+W)**2)
23182         U  =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
23183         R  = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
23184         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23185      &    'PHO_HARKIN:weight error',M
23186         IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
23187         V  =-1.D0-U
23188         X2 = X1
23189         X1 = 1.D0
23190       ELSEIF ( M.EQ.11) THEN
23191 110     CALL PHO_HARDX1
23192         WL = LOG(W1)
23193         U  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23194         V  =-1.D0-U
23195         R  = (U*U+V*V)/V*WL*AXX
23196         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23197      &    'PHO_HARKIN:weight error',M
23198         IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
23199         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23200         X2 = X1
23201         X1 = 1.D0
23202       ELSEIF ( M.EQ.12 ) THEN
23203 120     CALL PHO_HARDX1
23204         WL = LOG(AXX/(1.D0+W)**2)
23205         V  =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
23206         R  = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
23207         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23208      &    'PHO_HARKIN:weight error',M
23209         IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
23210       ELSEIF ( M.EQ.13) THEN
23211 130     CALL PHO_HARDX1
23212         WL = LOG(W1)
23213         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23214         U  =-1.D0-V
23215         R  = (U*U+V*V)/U*WL*AXX
23216         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23217      &    'PHO_HARKIN:weight error',M
23218         IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
23219         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23220 C------------- (double) direct process -----------
23221       ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
23222         X1 = 1.D0
23223         X2 = 1.D0
23224         AXX= AH
23225         W  = SQRT(MAX(TINY,1.D0-AXX))
23226         W1 = AXX/(1.D0+W)
23227         WL = LOG(W1)
23228  140    V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23229         U  =-1.D0-V
23230         R  = -(U*U+V*V)/U
23231         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23232      &    'PHO_HARKIN:weight error',M
23233         IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
23234         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23235 C---------------------------------------------
23236       ELSE
23237         WRITE(LO,'(/1X,A,I3)')
23238      &    'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
23239         CALL PHO_ABORT
23240       ENDIF
23241
23242       V    = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23243       U    = -1.D0-V
23244       U    = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23245       PT   = SQRT(U*V*X1*X2)*ECMP
23246       ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23247       ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23248
23249 ***************************************************************
23250       MM = M
23251       IF(M.EQ.-1) MM = 3
23252       ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23253       ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23254       ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23255       ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23256       XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23257       XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23258       XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23259       XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23260 ***************************************************************
23261
23262       IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23263      &  'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23264
23265       END
23266
23267 *$ CREATE PHO_HARWGH.FOR
23268 *COPY PHO_HARWGH
23269 CDECK  ID>, PHO_HARWGH
23270       SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23271 C***********************************************************************
23272 C
23273 C     calculate product of PDFs and coupling constants
23274 C     according to selected MSPR (process type)
23275 C
23276 C     input:    /POCKIN/
23277 C
23278 C     output:   PDS     resulting from PDFs alone
23279 C               FDISTR  complete weight function
23280 C               PDA,PDB fields containing the PDFs
23281 C
23282 C***********************************************************************
23283       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23284       SAVE
23285
23286       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23287
23288 C  input/output channels
23289       INTEGER LI,LO
23290       COMMON /POINOU/ LI,LO
23291 C  event debugging information
23292       INTEGER NMAXD
23293       PARAMETER (NMAXD=100)
23294       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23295      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23296       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23297      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23298 C  model switches and parameters
23299       CHARACTER*8 MDLNA
23300       INTEGER ISWMDL,IPAMDL
23301       DOUBLE PRECISION PARMDL
23302       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23303 C  data of c.m. system of Pomeron / Reggeon exchange
23304       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23305       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23306      &                 SIDP,CODP,SIFP,COFP
23307       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23308      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23309      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23310 C  currently activated parton density parametrizations
23311       CHARACTER*8 PDFNAM
23312       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23313       DOUBLE PRECISION PDFLAM,PDFQ2M
23314       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23315      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23316 C  hard scattering parameters used for most recent hard interaction
23317       INTEGER NFbeta,NF
23318       DOUBLE PRECISION ALQCD2,BQCD
23319       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23320 C  some hadron information, will be deleted in future versions
23321       INTEGER NFS
23322       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23323       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23324 C  scale parameters for parton model calculations
23325       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23326       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23327       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23328      &                NQQAL,NQQALI,NQQALF,NQQPD
23329 C  data on most recent hard scattering
23330       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23331       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23332      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23333      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23334       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23335      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23336      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23337      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23338      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23339 C  hard cross sections and MC selection weights
23340       INTEGER Max_pro_2
23341       PARAMETER ( Max_pro_2 = 16 )
23342       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23343      &  MH_acc_1,MH_acc_2
23344       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23345       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23346      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23347      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23348      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23349      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23350 C  some constants
23351       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23352       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23353      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23354
23355       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23356       DIMENSION PDA(-6:6),PDB(-6:6)
23357
23358       FDISTR = 0.D0
23359 C  set hard scale  QQ  for alpha and partondistr.
23360       IF     ( NQQAL.EQ.1 ) THEN
23361         QQAL = AQQAL*PT*PT
23362       ELSEIF ( NQQAL.EQ.2 ) THEN
23363         QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23364       ELSEIF ( NQQAL.EQ.3 ) THEN
23365         QQAL = AQQAL*X1*X2*ECMP*ECMP
23366       ELSEIF ( NQQAL.EQ.4 ) THEN
23367         QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23368       ENDIF
23369       IF     ( NQQPD.EQ.1 ) THEN
23370         QQPD = AQQPD*PT*PT
23371       ELSEIF ( NQQPD.EQ.2 ) THEN
23372         QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23373       ELSEIF ( NQQPD.EQ.3 ) THEN
23374         QQPD = AQQPD*X1*X2*ECMP*ECMP
23375       ELSEIF ( NQQPD.EQ.4 ) THEN
23376         QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23377       ENDIF
23378 C  coupling constants, PDFs
23379       IF(MSPR.LT.9) THEN
23380         ALPHA1 = PHO_ALPHAS(QQAL,3)
23381         ALPHA2 = ALPHA1
23382         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23383         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23384         IF ( MSPR.EQ.1  .OR.  MSPR.EQ.4 ) THEN
23385           PDS   = PDA(0)*PDB(0)
23386         ELSE
23387           S2    = 0.D0
23388           S3    = 0.D0
23389           S4    = 0.D0
23390           S5    = 0.D0
23391           DO 10 I=1,NF
23392             S2  = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23393             S3  = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23394             S4  = S4+PDA(I)+PDA(-I)
23395             S5  = S5+PDB(I)+PDB(-I)
23396  10       CONTINUE
23397           IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23398             PDS = S2
23399           ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23400             PDS = PDA(0)*S5+PDB(0)*S4
23401           ELSE IF(MSPR.EQ.7) THEN
23402             PDS = S3
23403           ELSE IF(MSPR.EQ.8) THEN
23404             PDS = S4*S5-(S2+S3)
23405           ENDIF
23406         ENDIF
23407       ELSE IF(MSPR.LT.12) THEN
23408         ALPHA2 = PHO_ALPHAS(QQAL,2)
23409         IF(IDPDG1.EQ.22) THEN
23410           ALPHA1 = pho_alphae(QQAL)
23411         ELSE IF(IDPDG1.EQ.990) THEN
23412           ALPHA1 = PARMDL(74)
23413         ENDIF
23414         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23415         S4    = 0.D0
23416         S6    = 0.D0
23417         DO 15 I=1,NF
23418           S4  = S4+PDB(I)+PDB(-I)
23419 C  charge counting
23420 *         IF(MOD(I,2).EQ.0) THEN
23421 *           S6  = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23422 *         ELSE
23423 *           S6  = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23424 *         ENDIF
23425           S6  = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23426  15     CONTINUE
23427         IF(MSPR.EQ.10) THEN
23428           IF(IDPDG1.EQ.990) THEN
23429             PDS = S4
23430           ELSE
23431             PDS = S6
23432           ENDIF
23433         ELSE
23434           PDS = PDB(0)
23435         ENDIF
23436       ELSE IF(MSPR.LT.14) THEN
23437         ALPHA1 = PHO_ALPHAS(QQAL,1)
23438         IF(IDPDG2.EQ.22) THEN
23439           ALPHA2 = pho_alphae(QQAL)
23440         ELSE IF(IDPDG2.EQ.990) THEN
23441           ALPHA2 = PARMDL(74)
23442         ENDIF
23443         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23444         S4    = 0.D0
23445         S6    = 0.D0
23446         DO 20 I=1,NF
23447           S4  = S4+PDA(I)+PDA(-I)
23448 C  charge counting
23449 *         IF(MOD(I,2).EQ.0) THEN
23450 *           S6  = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23451 *         ELSE
23452 *           S6  = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23453 *         ENDIF
23454           S6  = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23455  20     CONTINUE
23456         IF(MSPR.EQ.12) THEN
23457           IF(IDPDG2.EQ.990) THEN
23458             PDS = S4
23459           ELSE
23460             PDS = S6
23461           ENDIF
23462         ELSE
23463           PDS = PDA(0)
23464         ENDIF
23465       ELSE IF(MSPR.EQ.14) THEN
23466         SSR = X1*X2*ECMP*ECMP
23467         IF(IDPDG1.EQ.22) THEN
23468           ALPHA1 = pho_alphae(SSR)
23469         ELSE IF(IDPDG1.EQ.990) THEN
23470           ALPHA1 = PARMDL(74)
23471         ENDIF
23472         IF(IDPDG2.EQ.22) THEN
23473           ALPHA2 = pho_alphae(SSR)
23474         ELSE IF(IDPDG2.EQ.990) THEN
23475           ALPHA2 = PARMDL(74)
23476         ENDIF
23477         PDS = 1.D0
23478       ELSE
23479         WRITE(LO,'(/1X,A,I4)')
23480      &    'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23481         CALL PHO_ABORT
23482       ENDIF
23483
23484 C  complete weight
23485       FDISTR  = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23486
23487 C  debug output
23488       IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23489      &    'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23490      &    MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23491
23492       END
23493
23494 *$ CREATE PHO_HARSCA.FOR
23495 *COPY PHO_HARSCA
23496 CDECK  ID>, PHO_HARSCA
23497       SUBROUTINE PHO_HARSCA(IMODE,IP)
23498 C***********************************************************************
23499 C
23500 C     PHO_HARSCA determines the type of hard subprocess, the partons
23501 C     taking part in this subprocess and the kinematic variables
23502 C
23503 C     input:  IMODE   1   direct processes
23504 C                     2   resolved processes
23505 C                     -1  initialization
23506 C                     -2  output of statistics
23507 C             IP      1-4 particle combination (hadron/photon)
23508 C
23509 C***********************************************************************
23510       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23511       SAVE
23512
23513       PARAMETER( EPS  = 1.D-10,
23514      &           DEPS = 1.D-30 )
23515
23516 C  input/output channels
23517       INTEGER LI,LO
23518       COMMON /POINOU/ LI,LO
23519 C  event debugging information
23520       INTEGER NMAXD
23521       PARAMETER (NMAXD=100)
23522       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23523      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23524       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23525      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23526 C  model switches and parameters
23527       CHARACTER*8 MDLNA
23528       INTEGER ISWMDL,IPAMDL
23529       DOUBLE PRECISION PARMDL
23530       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23531 C  internal rejection counters
23532       INTEGER NMXJ
23533       PARAMETER (NMXJ=60)
23534       CHARACTER*10 REJTIT
23535       INTEGER IFAIL
23536       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23537 C  hard scattering parameters used for most recent hard interaction
23538       INTEGER NFbeta,NF
23539       DOUBLE PRECISION ALQCD2,BQCD
23540       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23541 C  data of c.m. system of Pomeron / Reggeon exchange
23542       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23543       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23544      &                 SIDP,CODP,SIFP,COFP
23545       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23546      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23547      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23548 C  names of hard scattering processes
23549       INTEGER Max_pro_1
23550       PARAMETER ( Max_pro_1 = 16 )
23551       CHARACTER*18 PROC
23552       COMMON /POHPRO/ PROC(0:Max_pro_1)
23553 C  data on most recent hard scattering
23554       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23555       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23556      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23557      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23558       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23559      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23560      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23561      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23562      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23563 C  hard scattering data
23564       INTEGER MSCAHD
23565       PARAMETER ( MSCAHD = 50 )
23566       INTEGER LSCAHD,LSC1HD,LSIDX,
23567      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23568       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23569       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23570      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23571      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23572      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23573      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23574      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23575      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23576 C  hard cross sections and MC selection weights
23577       INTEGER Max_pro_2
23578       PARAMETER ( Max_pro_2 = 16 )
23579       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23580      &  MH_acc_1,MH_acc_2
23581       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23582       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23583      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23584      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23585      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23586      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23587 C  cross sections
23588       INTEGER IPFIL,IFAFIL,IFBFIL
23589       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23590      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23591      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23592      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23593      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23594       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23595      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23596      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23597      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23598      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23599      &                IPFIL,IFAFIL,IFBFIL
23600 C  some constants
23601       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23602       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23603      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23604
23605  111  CONTINUE
23606
23607 C  resolved processes
23608       IF(IMODE.EQ.2) THEN
23609
23610         MH_pro_on(0,IP) = 0
23611         HWgx(9)  = 0.D0
23612         DO 15 M=-1,8
23613           IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23614  15     CONTINUE
23615         IF(HWgx(9).LT.DEPS) THEN
23616           WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23617      &      'no resolved process possible for IP',IP,HWgx(9)
23618           CALL PHO_ABORT
23619         ENDIF
23620 C
23621 C ----------------------------------------------I
23622 C  begin of iteration loop (resolved processes) I
23623 C                                               I
23624         IREJSC = 0
23625  10     CONTINUE
23626         IREJSC = IREJSC+1
23627         IF(IREJSC.GT.1000) THEN
23628           WRITE(LO,'(/1X,A,I10)')
23629      &      'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23630             CALL PHO_ABORT
23631         ENDIF
23632
23633 C  find subprocess
23634         B      = DT_RNDM(X1)*HWgx(9)
23635         MSPR   =-2
23636         SUM    = 0.D0
23637  20     MSPR   = MSPR+1
23638         IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23639         IF ( SUM.LT.B  .AND. MSPR.LT.8 ) GOTO 20
23640
23641         IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23642      &    'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23643
23644 C  find kin. variables X1,X2 and V
23645         CALL PHO_HARKIN(IREJ)
23646         IF(IREJ.NE.0) THEN
23647           IFAIL(29) = IFAIL(29)+1
23648           GOTO 10
23649         ENDIF
23650 C  calculate remaining distribution
23651         CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23652 C  actualize counter for cross-section calculation
23653         if(F.LE.1.D-15) then
23654           F = 0.D0
23655           goto 10
23656         endif
23657 *       XSECT(5,MSPR) = XSECT(5,MSPR)+F
23658 *       XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23659         MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23660 C  check F against FMAX
23661         WEIGHT = F/(HWgx(MSPR)+DEPS)
23662         IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23663 C-------------------------------------------------------------------
23664         IF(WEIGHT.GT.1.D0) THEN
23665           WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23666  1234     FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23667      &      2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23668           WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23669      &      ECMP,PTWANT,AS,AH,PT
23670           WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23671      &      ETAC,ETAD,X1,X2,V
23672           CALL PHO_PREVNT(-1)
23673         ENDIF
23674 C-------------------------------------------------------------------
23675 C                                             I
23676 C  end of iteration loop (resolved processes) I
23677 C --------------------------------------------I
23678 C
23679 C*********************************************************************
23680 C
23681 C  direct processes
23682
23683       ELSE IF(IMODE.EQ.1) THEN
23684
23685 C  single-resolved processes kinematically forbidden
23686         if(Z1DIF.lt.0.D0) then
23687           HWgx(10) = 0.D0
23688           HWgx(11) = 0.D0
23689           HWgx(12) = 0.D0
23690           HWgx(13) = 0.D0
23691         endif
23692
23693         HWgx(15)  = 0.D0
23694         if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23695           DO M= 10,14
23696             IF(MH_pro_on(M,IP).EQ.1) then
23697               if((M.eq.10).or.(M.eq.11)) then
23698                 fac = FSUH(1)*FSUP(2)
23699               else if((M.eq.12).or.(M.eq.13)) then
23700                 fac = FSUP(1)*FSUH(2)
23701               else
23702                 fac = FSUH(1)*FSUH(2)
23703               endif
23704               HWgx(15) = HWgx(15)+HWgx(M)*fac
23705             endif
23706           ENDDO
23707         else
23708           DO M= 10,14
23709             IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23710           ENDDO
23711         endif
23712         IF(HWgx(15).LT.DEPS) THEN
23713           WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23714      &      'no direct/single-resolved process possible (IP)',IP
23715           CALL PHO_ABORT
23716         ENDIF
23717 C
23718 C ----------------------------------------------I
23719 C  begin of iteration loop (direct processes)   I
23720 C                                               I
23721         IREJSC = 0
23722  100    CONTINUE
23723         IREJSC = IREJSC+1
23724         IF(IREJSC.GT.1000) THEN
23725           WRITE(LO,'(/1X,A,I10)')
23726      &      'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23727             CALL PHO_ABORT
23728         ENDIF
23729
23730 C  find subprocess
23731         B      = DT_RNDM(X1)*HWgx(15)
23732         MSPR   = 9
23733         SUM    = 0.D0
23734         if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23735  150      continue
23736             MSPR   = MSPR+1
23737             IF(MH_pro_on(MSPR,IP).EQ.1) then
23738               if((MSPR.eq.10).or.(MSPR.eq.11)) then
23739                 fac = FSUH(1)*FSUP(2)
23740               else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23741                 fac = FSUP(1)*FSUH(2)
23742               else
23743                 fac = FSUH(1)*FSUH(2)
23744               endif
23745               SUM = SUM+HWgx(MSPR)*fac
23746             endif
23747           IF ( SUM.LT.B  .AND. MSPR.LT.14 ) GOTO 150
23748         else
23749  200      continue
23750             MSPR   = MSPR+1
23751             IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23752           IF ( SUM.LT.B  .AND. MSPR.LT.14 ) GOTO 200
23753         endif
23754
23755         IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23756      &    'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23757
23758 C  find kin. variables X1,X2 and V
23759         CALL PHO_HARKIN(IREJ)
23760         IF(IREJ.NE.0) THEN
23761           IFAIL(28) = IFAIL(28)+1
23762           GOTO 100
23763         ENDIF
23764
23765 C  calculate remaining distribution
23766         CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23767
23768 C  counter for cross-section calculation
23769         if(F.LE.1.D-15) then
23770           F=0.D0
23771           goto 100
23772         endif
23773 *       XSECT(5,MSPR) = XSECT(5,MSPR)+F
23774 *       XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23775         MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23776 C  check F against FMAX
23777         WEIGHT = F/(HWgx(MSPR)+DEPS)
23778         IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23779 C-------------------------------------------------------------------
23780         IF(WEIGHT.GT.1.D0) THEN
23781           WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23782  1235     FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23783      &      2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23784           WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23785      &      ECMP,PTWANT,AS,AH,PT
23786           WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23787      &      ETAC,ETAD,X1,X2,V
23788           CALL PHO_PREVNT(-1)
23789         ENDIF
23790 C-------------------------------------------------------------------
23791 C                                             I
23792 C  end of iteration loop (direct processes)   I
23793 C --------------------------------------------I
23794
23795       ELSE IF(IMODE.EQ.-1) THEN
23796
23797 C  initialize cross section calculations
23798
23799         DO 40 M=-1,Max_pro_2
23800 *         DO 30 I=5,6
23801 *           XSECT(I,M) = 0.D0
23802 *30       CONTINUE
23803 C  reset counters
23804           DO 35 J=1,4
23805             MH_tried(M,J) = 0
23806             MH_acc_1(M,J) = 0
23807             MH_acc_2(M,J) = 0
23808  35       CONTINUE
23809  40     CONTINUE
23810         IF(IDEB(78).GE.0) THEN
23811           WRITE(LO,'(/1X,A,/1X,A)')
23812      &      'PHO_HARSCA: activated hard processes',
23813      &      '------------------------------------'
23814           WRITE(LO,'(5X,A)') 'PROCESS,    IP= 1 ... 4 (on/off)'
23815           DO 42 M=1,Max_pro_2
23816             WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23817      &        (MH_pro_on(M,J),J=1,4)
23818  42       CONTINUE
23819         ENDIF
23820         RETURN
23821
23822       ELSE IF(IMODE.EQ.-2) THEN
23823
23824 C  calculation of process statistics
23825
23826         do K=1,4
23827
23828           MH_tried(0,K)  = 0
23829           MH_acc_1(0,K)  = 0
23830           MH_acc_2(0,K)  = 0
23831           MH_tried(9,K)  = 0
23832           MH_acc_1(9,K)  = 0
23833           MH_acc_2(9,K)  = 0
23834           MH_tried(15,K) = 0
23835           MH_acc_1(15,K) = 0
23836           MH_acc_2(15,K) = 0
23837
23838           MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23839           MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23840           MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23841
23842           do M=1,8
23843             MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23844             MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23845             MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23846           enddo
23847           do M=10,14
23848             MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23849             MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23850             MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23851           enddo
23852           MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23853           MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23854           MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23855         enddo
23856
23857         IF(IDEB(78).GE.1) THEN
23858           WRITE(LO,'(/1X,A,/1X,A)')
23859      &      'PHO_HARSCA: internal rejection statistics',
23860      &      '-----------------------------------------'
23861           do K=1,4
23862             IF(MH_tried(0,K).GT.0) THEN
23863               WRITE(LO,'(5X,A,I3)')
23864      &          'process (sampled/accepted) for IP:',K
23865               do M=0,Max_pro_2
23866                 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23867      &            MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23868      &            dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23869               enddo
23870             ENDIF
23871           enddo
23872         ENDIF
23873         RETURN
23874
23875       ELSE
23876         WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23877      &    'unsupported mode',IMODE
23878         CALL PHO_ABORT
23879       ENDIF
23880
23881 C  the event is accepted now
23882 C  actualize counter for accepted events
23883       MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23884       IF(MSPR.EQ.-1) MSPR = 3
23885 C
23886 C  find flavor of initial partons
23887 C
23888       SUM    = 0.D0
23889       SCHECK = DT_RNDM(SUM)*PDS-EPS
23890       IF     ( MSPR.EQ.1  .OR.  MSPR.EQ.4 ) THEN
23891         IA = 0
23892         IB = 0
23893       ELSEIF ( MSPR.EQ.2  .OR.  MSPR.EQ.5  .OR.  MSPR.EQ.6 ) THEN
23894         DO 610 IA=-NF,NF
23895           IF ( IA.EQ.0 ) GOTO 610
23896           SUM  = SUM+PDF1(IA)*PDF2(-IA)
23897           IF ( SUM.GE.SCHECK ) GOTO 620
23898  610      CONTINUE
23899  620    IB =-IA
23900       ELSEIF ( MSPR.EQ.3 ) THEN
23901         IB     = 0
23902         DO 630 IA=-NF,NF
23903           IF ( IA.EQ.0 ) GOTO 630
23904           SUM  = SUM+PDF1(0)*PDF2(IA)
23905           IF ( SUM.GE.SCHECK ) GOTO 640
23906           SUM  = SUM+PDF1(IA)*PDF2(0)
23907           IF ( SUM.GE.SCHECK ) GOTO 650
23908  630    CONTINUE
23909  640    IB     = IA
23910         IA     = 0
23911  650    CONTINUE
23912       ELSEIF ( MSPR.EQ.7 ) THEN
23913         DO 660 IA=-NF,NF
23914           IF ( IA.EQ.0 ) GOTO 660
23915           SUM  = SUM+PDF1(IA)*PDF2(IA)
23916           IF ( SUM.GE.SCHECK ) GOTO 670
23917  660      CONTINUE
23918  670    IB     = IA
23919       ELSEIF ( MSPR.EQ.8 ) THEN
23920         DO 690 IA=-NF,NF
23921           IF ( IA.EQ.0 ) GOTO 690
23922           DO 680 IB=-NF,NF
23923             IF ( ABS(IB).EQ.ABS(IA)  .OR.  IB.EQ.0 ) GOTO 680
23924             SUM = SUM+PDF1(IA)*PDF2(IB)
23925             IF ( SUM.GE.SCHECK ) GOTO 700
23926  680        CONTINUE
23927  690      CONTINUE
23928  700    CONTINUE
23929       ELSEIF ( MSPR.EQ.10 ) THEN
23930         IA     = 0
23931         DO 710 IB=-NF,NF
23932           IF ( IB.NE.0 ) THEN
23933             IF(IDPDG1.EQ.22) THEN
23934 *             IF(MOD(ABS(IB),2).EQ.0) THEN
23935 *               SUM = SUM+PDF2(IB)*4.D0/9.D0
23936 *             ELSE
23937 *               SUM = SUM+PDF2(IB)*1.D0/9.D0
23938 *             ENDIF
23939               SUM = SUM+PDF2(IB)*Q_ch2(IB)
23940             ELSE
23941               SUM = SUM+PDF2(IB)
23942             ENDIF
23943             IF ( SUM.GE.SCHECK ) GOTO 720
23944           ENDIF
23945  710    CONTINUE
23946  720    CONTINUE
23947       ELSEIF ( MSPR.EQ.12 ) THEN
23948         IB     = 0
23949         DO 810 IA=-NF,NF
23950           IF ( IA.NE.0 ) THEN
23951             IF(IDPDG2.EQ.22) THEN
23952 *             IF(MOD(ABS(IA),2).EQ.0) THEN
23953 *               SUM = SUM+PDF1(IA)*4.D0/9.D0
23954 *             ELSE
23955 *               SUM = SUM+PDF1(IA)*1.D0/9.D0
23956 *             ENDIF
23957               SUM = SUM+PDF1(IA)*Q_ch2(IA)
23958             ELSE
23959               SUM = SUM+PDF1(IA)
23960             ENDIF
23961             IF ( SUM.GE.SCHECK ) GOTO 820
23962           ENDIF
23963  810    CONTINUE
23964  820    CONTINUE
23965       ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23966         IA     = 0
23967         IB     = 0
23968       ENDIF
23969 C  final check
23970       IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
23971         write(LO,*) 'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23972         write(LO,*) 'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
23973         GOTO 111
23974       ENDIF
23975 C
23976 C  find flavour of final partons
23977 C
23978       IC = IA
23979       ID = IB
23980       IF     ( MSPR.EQ.2 ) THEN
23981         IC = 0
23982         ID = 0
23983       ELSEIF ( MSPR.EQ.4 ) THEN
23984         IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23985         IF ( IC.GT.NF ) IC = NF-IC
23986         ID =-IC
23987       ELSEIF ( MSPR.EQ.6 ) THEN
23988         IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23989         IF ( IC.GT.NF-1 ) IC = NF-1-IC
23990         IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23991         ID =-IC
23992       ELSEIF ( MSPR.EQ.11) THEN
23993         SUM = 0.D0
23994         DO 730 IC=-NF,NF
23995           IF ( IC.NE.0 ) THEN
23996             IF(IDPDG1.EQ.22) THEN
23997 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23998 *               SUM = SUM + 4.D0
23999 *             ELSE
24000 *               SUM = SUM + 1.D0
24001 *             ENDIF
24002               SUM = SUM + Q_ch2(IC)
24003             ELSE
24004               SUM = SUM + 1.D0
24005             ENDIF
24006           ENDIF
24007  730    CONTINUE
24008         SCHECK = DT_RNDM(SUM)*SUM-EPS
24009         SUM = 0.D0
24010         DO 740 IC=-NF,NF
24011           IF ( IC.NE.0 ) THEN
24012             IF(IDPDG1.EQ.22) THEN
24013 *             IF(MOD(ABS(IC),2).EQ.0) THEN
24014 *               SUM = SUM + 4.D0
24015 *             ELSE
24016 *               SUM = SUM + 1.D0
24017 *             ENDIF
24018               SUM = SUM + Q_ch2(IC)
24019             ELSE
24020               SUM = SUM + 1.D0
24021             ENDIF
24022             IF ( SUM.GE.SCHECK ) GOTO 750
24023           ENDIF
24024  740    CONTINUE
24025  750    CONTINUE
24026         ID = -IC
24027       ELSEIF ( MSPR.EQ.12) THEN
24028         IC = 0
24029         ID = IA
24030       ELSEIF ( MSPR.EQ.13) THEN
24031         SUM = 0.D0
24032         DO 830 IC=-NF,NF
24033           IF ( IC.NE.0 ) THEN
24034             IF(IDPDG2.EQ.22) THEN
24035 *             IF(MOD(ABS(IC),2).EQ.0) THEN
24036 *               SUM = SUM + 4.D0
24037 *             ELSE
24038 *               SUM = SUM + 1.D0
24039 *             ENDIF
24040               SUM = SUM +  Q_ch2(IC)
24041             ELSE
24042               SUM = SUM + 1.D0
24043             ENDIF
24044           ENDIF
24045  830    CONTINUE
24046         SCHECK = DT_RNDM(SUM)*SUM-EPS
24047         SUM = 0.D0
24048         DO 840 IC=-NF,NF
24049           IF ( IC.NE.0 ) THEN
24050             IF(IDPDG2.EQ.22) THEN
24051 *             IF(MOD(ABS(IC),2).EQ.0) THEN
24052 *               SUM = SUM + 4.D0
24053 *             ELSE
24054 *               SUM = SUM + 1.D0
24055 *             ENDIF
24056               SUM = SUM +  Q_ch2(IC)
24057             ELSE
24058               SUM = SUM + 1.D0
24059             ENDIF
24060             IF ( SUM.GE.SCHECK ) GOTO 850
24061           ENDIF
24062  840    CONTINUE
24063  850    CONTINUE
24064         ID = -IC
24065       ELSEIF ( MSPR.EQ.14) THEN
24066         SUM = 0.D0
24067         DO 930 IC=1,NF
24068           FAC1 = 1.D0
24069           FAC2 = 1.D0
24070           IF(MOD(ABS(IC),2).EQ.0) THEN
24071             IF(IDPDG1.EQ.22) FAC1 = 4.D0
24072             IF(IDPDG2.EQ.22) FAC2 = 4.D0
24073           ENDIF
24074           SUM = SUM + FAC1*FAC2
24075  930    CONTINUE
24076         IF(IPAMDL(64).NE.0) THEN
24077           IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
24078         ENDIF
24079         SCHECK = DT_RNDM(SUM)*SUM-EPS
24080         SUM = 0.D0
24081         DO 940 IC=1,NF
24082           FAC1 = 1.D0
24083           FAC2 = 1.D0
24084           IF(MOD(ABS(IC),2).EQ.0) THEN
24085             IF(IDPDG1.EQ.22) FAC1 = 4.D0
24086             IF(IDPDG2.EQ.22) FAC2 = 4.D0
24087           ENDIF
24088           SUM = SUM + FAC1*FAC2
24089           IF ( SUM.GE.SCHECK ) GOTO 950
24090  940    CONTINUE
24091         IC = 15
24092  950    CONTINUE
24093         ID = -IC
24094         IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
24095       ENDIF
24096       if(IC.eq.0) then
24097         XM3 = 0.D0
24098       else
24099         XM3 = PHO_PMASS(IC,3)
24100       endif
24101       if(ID.eq.0) then
24102         XM4 = 0.D0
24103       else
24104         XM4 = PHO_PMASS(ID,3)
24105       endif
24106       IF(ABS(IC).EQ.15) GOTO 955
24107
24108 C  valence quarks involved?
24109       IV1 = 0
24110       IF(IA.NE.0) THEN
24111         IF(IDPDG1.EQ.22) THEN
24112           CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
24113           IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
24114         ELSE
24115           IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
24116         ENDIF
24117       ENDIF
24118       IV2 = 0
24119       IF(IB.NE.0) THEN
24120         IF(IDPDG2.EQ.22) THEN
24121           CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
24122           IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
24123         ELSE
24124           IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
24125         ENDIF
24126       ENDIF
24127 C
24128 C  fill event record
24129 C
24130  955  CONTINUE
24131       CALL PHO_SFECFE(SINPHI,COSPHI)
24132       ECM2 = ECMP/2.D0
24133 C  incoming partons
24134       PHI1(1) = 0.D0
24135       PHI1(2) = 0.D0
24136       PHI1(3) = ECM2*X1
24137       PHI1(4) = PHI1(3)
24138       PHI1(5) = 0.D0
24139       PHI2(1) = 0.D0
24140       PHI2(2) = 0.D0
24141       PHI2(3) = -ECM2*X2
24142       PHI2(4) = -PHI2(3)
24143       PHI2(5) = 0.D0
24144 C  outgoing partons
24145       PHO1(1) = PT*COSPHI
24146       PHO1(2) = PT*SINPHI
24147       PHO1(3) = -ECM2*(U*X1-V*X2)
24148       PHO1(4) = -ECM2*(U*X1+V*X2)
24149       PHO1(5) = XM3
24150       PHO2(1) = -PHO1(1)
24151       PHO2(2) = -PHO1(2)
24152       PHO2(3) = -ECM2*(V*X1-U*X2)
24153       PHO2(4) = -ECM2*(V*X1+U*X2)
24154       PHO2(5) = XM4
24155
24156 C  convert to mass shell
24157       CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
24158       IF(IREJ.NE.0) THEN
24159         IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
24160      &    'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
24161      &    PT,XM3,XM4
24162         GOTO 111
24163       ENDIF
24164       PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
24165
24166 C  debug output
24167       IF(IDEB(78).GE.20) THEN
24168         SHAT = X1*X2*ECMP*ECMP
24169         WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
24170      &    MSPR,IA,IB,IC,ID
24171         WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
24172         WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
24173         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
24174         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
24175         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
24176         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
24177       ENDIF
24178
24179       END
24180
24181 *$ CREATE PHO_HARFAC.FOR
24182 *COPY PHO_HARFAC
24183 CDECK  ID>, PHO_HARFAC
24184       SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
24185 C*********************************************************************
24186 C
24187 C     initialization: find scaling factors and maxima of remaining
24188 C                     weights
24189 C
24190 C     input:   PTCUT  transverse momentum cutoff
24191 C              ECMI   cms energy
24192 C
24193 C     output:  Hfac(-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 ( MXABWT = 96 )
24200
24201 C  input/output channels
24202       INTEGER LI,LO
24203       COMMON /POINOU/ LI,LO
24204 C  data of c.m. system of Pomeron / Reggeon exchange
24205       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24206       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24207      &                 SIDP,CODP,SIFP,COFP
24208       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24209      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
24210      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
24211 C  some constants
24212       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24213       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24214      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24215 C  hard scattering parameters used for most recent hard interaction
24216       INTEGER NFbeta,NF
24217       DOUBLE PRECISION ALQCD2,BQCD
24218       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24219 C  integration precision for hard cross sections (obsolete)
24220       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24221       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24222 C  data on most recent hard scattering
24223       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24224       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24225      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24226      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24227       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24228      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24229      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24230      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24231      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24232 C  hard cross sections and MC selection weights
24233       INTEGER Max_pro_2
24234       PARAMETER ( Max_pro_2 = 16 )
24235       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24236      &  MH_acc_1,MH_acc_2
24237       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24238       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24239      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24240      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24241      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24242      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24243
24244       DIMENSION       ABSZ(MXABWT),WEIG(MXABWT)
24245       DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24246      &          F124(-1:Max_pro_2)
24247       DATA F124 / 1.D0,0.D0,
24248      &            4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24249      &            2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24250
24251       SS     = ECMI*ECMI
24252       AH     = (2.D0*PTCUT/ECMI)**2
24253       ALN    = LOG(AH)
24254       HLN    = LOG(0.5D0)
24255       NPOINT = NGAUIN
24256       CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24257       DO 10 M=-1,Max_pro_2
24258         S1(M) = 0.D0
24259 10    CONTINUE
24260
24261 C  resolved processes
24262       DO 80 I1=1,NPOINT
24263         Z1   = ABSZ(I1)
24264         X1   = EXP(ALN*Z1)
24265         DO 20 M=-1,9
24266           S2(M) = 0.D0
24267 20      CONTINUE
24268
24269         DO 60 I2=1,NPOINT
24270           Z2    = (1.D0-Z1)*ABSZ(I2)
24271           X2    = EXP(ALN*Z2)
24272           FAXX  = AH/(X1*X2)
24273           W     = SQRT(1.D0-FAXX)
24274           W1    = FAXX/(1.+W)
24275           WLOG  = LOG(W1)
24276           FWW   = FAXX*WLOG/W
24277           DO 30 M=-1,9
24278             S(M) = 0.D0
24279 30        CONTINUE
24280
24281           DO 40 I=1,NPOINT
24282             Z   = ABSZ(I)
24283             VA  =-0.5D0*W1/(W1+Z*W)
24284             UA  =-1.D0-VA
24285             VB  =-0.5D0*FAXX/(W1+2.D0*W*Z)
24286             UB  =-1.D0-VB
24287             VC  =-EXP(HLN+Z*WLOG)
24288             UC  =-1.D0-VC
24289             VE  =-0.5D0*(1.D0+W)+Z*W
24290             UE  =-1.D0-VE
24291             S(1)  = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24292      &           WEIG(I)
24293             S(2)  = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24294      &            WEIG(I)
24295             S(3)  = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24296             S(5)  = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24297      &            (8./27.)*UA*UA*VA)*WEIG(I)
24298             S(6)  = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24299             S(7)  = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24300      &            (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24301             S(8)  = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24302             S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
24303 40        CONTINUE
24304           S(4)    = S(2)*(9./32.)
24305           DO 50 M=-1,8
24306             S2(M) = S2(M)+S(M)*WEIG(I2)*W
24307 50        CONTINUE
24308 60      CONTINUE
24309         DO 70 M=-1,8
24310           S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
24311 70      CONTINUE
24312 80    CONTINUE
24313       S1(4) = S1(4)*NF
24314       S1(6) = S1(6)*MAX(0,NF-1)
24315 C
24316 C  direct processes
24317       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24318      &   .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24319         DO 180 I1=1,NPOINT
24320           Z2   = ABSZ(I1)
24321           X2   = EXP(ALN*Z2)
24322           FAXX  = AH/X2
24323           W     = SQRT(1.D0-FAXX)
24324           W1    = FAXX/(1.D0+W)
24325           WLOG  = LOG(W1)
24326           WL = LOG(FAXX/(1.D0+W)**2)
24327           FWW1  = FAXX*WL/ALN
24328           FWW2  = FAXX*WLOG/ALN
24329           DO 130 M=10,12
24330             S(M) = 0.D0
24331  130      CONTINUE
24332 C
24333           DO 140 I=1,NPOINT
24334             Z   = ABSZ(I)
24335             UA  =-(1.D0+W)/2.D0*EXP(Z*WL)
24336             VA  =-1.D0-UA
24337             VB  =-EXP(HLN+Z*WLOG)
24338             UB  =-1.D0-VB
24339             S(10)  = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24340             S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24341  140      CONTINUE
24342           DO 170 M=10,11
24343             S1(M) = S1(M)+S(M)*WEIG(I1)
24344  170      CONTINUE
24345  180    CONTINUE
24346         S1(12) = S1(10)
24347         S1(13) = S1(11)
24348 C  quark charges fractions
24349         IF(IDPDG1.EQ.22) THEN
24350           CHRNF = 0.D0
24351           DO 100 I=1,NF
24352             CHRNF = CHRNF + Q_ch2(I)
24353  100      CONTINUE
24354           S1(11) = S1(11)*CHRNF
24355         ELSE IF(IDPDG1.EQ.990) THEN
24356           S1(11) = S1(11)*NF
24357         ELSE
24358           S1(11) = 0.D0
24359         ENDIF
24360         IF(IDPDG2.EQ.22) THEN
24361           CHRNF = 0.D0
24362           DO 200 I=1,NF
24363             CHRNF = CHRNF + Q_ch2(I)
24364  200      CONTINUE
24365           S1(13) = S1(13)*CHRNF
24366         ELSE IF(IDPDG2.EQ.990) THEN
24367           S1(13) = S1(13)*NF
24368         ELSE
24369           S1(13) = 0.D0
24370         ENDIF
24371       ENDIF
24372 C
24373 C  global factors
24374       FFF    = PI*GEV2MB*ALN*ALN/(AH*SS)
24375       DO 90 M=-1,Max_pro_2
24376         Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
24377 90    CONTINUE
24378 C
24379 C  double direct process
24380       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24381      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24382         FAC = 0.D0
24383         DO 300 I=1,NF
24384           IF(IDPDG1.EQ.22) THEN
24385             F1 = Q_ch2(I)
24386           ELSE
24387             F1 = 1.D0
24388           ENDIF
24389           IF(IDPDG2.EQ.22) THEN
24390             F2 = Q_ch2(I)
24391           ELSE
24392             F2 = 1.D0
24393           ENDIF
24394           FAC = FAC+F1*F2*3.D0
24395  300    CONTINUE
24396         ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24397         Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24398      &               *GEV2MB*FAC
24399       ENDIF
24400       END
24401
24402 *$ CREATE PHO_HARWGX.FOR
24403 *COPY PHO_HARWGX
24404 CDECK  ID>, PHO_HARWGX
24405       SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24406 C**********************************************************************
24407 C
24408 C     find maximum of remaining weight for MC sampling
24409 C
24410 C     input:   PTCUT  transverse momentum cutoff
24411 C              ECM    cms energy
24412 C
24413 C     output:  HWgx(-1:Max_pro_2)  field for sampling hard processes
24414 C
24415 C**********************************************************************
24416       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24417       SAVE
24418
24419       PARAMETER ( NKM = 10 )
24420       PARAMETER ( TINY = 1.D-20 )
24421
24422 C  input/output channels
24423       INTEGER LI,LO
24424       COMMON /POINOU/ LI,LO
24425 C  event debugging information
24426       INTEGER NMAXD
24427       PARAMETER (NMAXD=100)
24428       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24429      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24430       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24431      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24432 C  data on most recent hard scattering
24433       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24434       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24435      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24436      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24437       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24438      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24439      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24440      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24441      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24442 C  hard cross sections and MC selection weights
24443       INTEGER Max_pro_2
24444       PARAMETER ( Max_pro_2 = 16 )
24445       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24446      &  MH_acc_1,MH_acc_2
24447       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24448       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24449      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24450      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24451      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24452      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24453
24454       DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24455      &  XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24456       DIMENSION IFTAB(-1:Max_pro_2)
24457       DATA IFTAB  / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24458
24459 C  initial settings
24460       AH    = (2.D0*PTCUT/ECM)**2
24461       ALNH  = LOG(AH)
24462       FF(0) = 0.D0
24463       DO 22 I=1,NKM
24464         FF(I) = 0.D0
24465         XM1(I) = 0.D0
24466         XM2(I) = 0.D0
24467         PTM(I) = 0.D0
24468         ZMX(1,I) = 0.D0
24469         ZMX(2,I) = 0.D0
24470         ZMX(3,I) = 0.D0
24471         DMX(1,I) = 0.D0
24472         DMX(2,I) = 0.D0
24473         DMX(3,I) = 0.D0
24474         IMX(I) = 0
24475         IPO(I) = 0
24476  22   CONTINUE
24477
24478       NKML = 10
24479       DO 40 NKON=1,NKML
24480
24481         DO 50 IST=1,3
24482 C  start configuration
24483         IF(IST.EQ.1) THEN
24484           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24485           Z(2) = 0.5
24486           Z(3) = 0.1
24487           D(1) =-0.5
24488           D(2) = 0.5
24489           D(3) = 0.5
24490         ELSE IF(IST.EQ.2) THEN
24491           Z(1) = 0.999D0
24492           Z(2) = 0.5
24493           Z(3) = 0.0
24494           D(1) =-0.5
24495           D(2) = 0.5
24496           D(3) = 0.5
24497         ELSE IF(IST.EQ.3) THEN
24498           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24499           Z(2) = 0.1
24500           Z(3) = 0.1
24501           D(1) =-0.5
24502           D(2) = 0.5
24503           D(3) = 0.5
24504         ELSE IF(IST.EQ.4) THEN
24505           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24506           Z(2) = 0.9
24507           Z(3) = 0.1
24508           D(1) =-0.5
24509           D(2) = 0.5
24510           D(3) = 0.5
24511         ENDIF
24512         IT   = 0
24513         CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24514 C  process possible?
24515         IF(F2.LE.0.D0) GOTO 35
24516
24517  10     CONTINUE
24518           IT   = IT+1
24519           FOLD = F2
24520           DO 30 I=1,3
24521             D(I) = D(I)/5.D0
24522             Z(I)   = Z(I)+D(I)
24523             CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24524             IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24525             IF ( F2.GT.F3 ) D(I) =-D(I)
24526  20         CONTINUE
24527               F1   = MIN(F2,F3)
24528               F2   = MAX(F2,F3)
24529               Z(I) = Z(I)+D(I)
24530               CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24531             IF ( F3.GT.F2 ) GOTO 20
24532             ZZ     = Z(I)-D(I)
24533             Z(I)   = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24534             IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24535      &        CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24536             IF ( F1.LE.F2 ) Z(I) = ZZ
24537             F2     = MAX(F1,F2)
24538  30       CONTINUE
24539         IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24540
24541         IF(F2.GT.FF(NKON)) THEN
24542           FF(NKON)  = MAX(F2,0.D0)
24543           XM1(NKON) = X1
24544           XM2(NKON) = X2
24545           PTM(NKON) = PT
24546           ZMX(1,NKON) = Z(1)
24547           ZMX(2,NKON) = Z(2)
24548           ZMX(3,NKON) = Z(3)
24549           DMX(1,NKON) = D(1)
24550           DMX(2,NKON) = D(2)
24551           DMX(3,NKON) = D(3)
24552           IMX(NKON) = IT
24553           IPO(NKON) = IST
24554         ENDIF
24555 C
24556  50     CONTINUE
24557  35     CONTINUE
24558  40   CONTINUE
24559
24560 C  debug output
24561       IF(IDEB(38).GE.5) THEN
24562         WRITE(LO,'(/1X,A)')
24563      &    'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24564         DO 60 I=1,NKM
24565           IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24566      &      IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24567      &      DMX(2,I),DMX(3,I)
24568  60     CONTINUE
24569       ENDIF
24570
24571       DO 70 I=-1,Max_pro_2
24572         HWgx(I)  = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24573  70   CONTINUE
24574
24575 C  debug output
24576       IF(IDEB(38).GE.5) THEN
24577         WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24578         WRITE(LO,'(5X,A)') 'I    X1   X2   PT   HWgx(I)  FDIS'
24579         DO 80 I=-1,Max_pro_2
24580           IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24581             MSPR = I
24582             X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24583             X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24584             PT = PTM(IFTAB(I))
24585             CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24586             WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24587           ENDIF
24588  80     CONTINUE
24589       ENDIF
24590
24591       END
24592
24593 *$ CREATE PHO_HARWGI.FOR
24594 *COPY PHO_HARWGI
24595 CDECK  ID>, PHO_HARWGI
24596       SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24597 C**********************************************************************
24598 C
24599 C     auxiliary subroutine to find maximum of remaining weight
24600 C
24601 C     input:  ECMX   current CMS energy
24602 C             PTCUT  current pt cutoff
24603 C             NKON   process label  1..5  resolved
24604 C                                   6..7  direct particle 1
24605 C                                   8..9  direct particle 2
24606 C                                   10    double direct
24607 C             Z(3)   transformed variable
24608 C
24609 C     output: remaining weight
24610 C
24611 C**********************************************************************
24612       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24613       SAVE
24614
24615       DIMENSION Z(3)
24616
24617       PARAMETER ( NKM   = 10 )
24618       PARAMETER ( TINY  = 1.D-30,
24619      &            TINY6 = 1.D-06 )
24620
24621 C  input/output channels
24622       INTEGER LI,LO
24623       COMMON /POINOU/ LI,LO
24624 C  event debugging information
24625       INTEGER NMAXD
24626       PARAMETER (NMAXD=100)
24627       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24628      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24629       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24630      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24631 C  model switches and parameters
24632       CHARACTER*8 MDLNA
24633       INTEGER ISWMDL,IPAMDL
24634       DOUBLE PRECISION PARMDL
24635       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24636 C  data of c.m. system of Pomeron / Reggeon exchange
24637       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24638       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24639      &                 SIDP,CODP,SIFP,COFP
24640       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24641      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
24642      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
24643 C  currently activated parton density parametrizations
24644       CHARACTER*8 PDFNAM
24645       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24646       DOUBLE PRECISION PDFLAM,PDFQ2M
24647       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24648      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24649 C  hard scattering parameters used for most recent hard interaction
24650       INTEGER NFbeta,NF
24651       DOUBLE PRECISION ALQCD2,BQCD
24652       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24653 C  some hadron information, will be deleted in future versions
24654       INTEGER NFS
24655       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24656       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24657 C  scale parameters for parton model calculations
24658       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24659       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24660       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24661      &                NQQAL,NQQALI,NQQALF,NQQPD
24662 C  data on most recent hard scattering
24663       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24664       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24665      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24666      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24667       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24668      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24669      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24670      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24671      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24672
24673       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24674       DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24675
24676       FDIS = 0.D0
24677
24678       IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24679      &  'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24680 C  check input values
24681       IF ( Z(1).LT.0.D0  .OR.  Z(1).GT.1.D0 ) RETURN
24682       IF ( Z(2).LT.0.D0  .OR.  Z(2).GT.1.D0 ) RETURN
24683       IF ( Z(3).LT.0.D0  .OR.  Z(3).GT.1.D0 ) RETURN
24684 C  transformations
24685       Y1    = EXP(ALNH*Z(1))
24686       IF(NKON.LE.5) THEN
24687 C  resolved kinematic
24688         Y2  =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24689         X1  = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24690         X2  = X1-Y2
24691         X1 = MIN(X1,0.999999999999D0)
24692         X2 = MIN(X2,0.999999999999D0)
24693       ELSE IF(NKON.LE.7) THEN
24694 C  direct kinematic 1
24695         X1 = 1.D0
24696         X2 = MIN(Y1,0.999999999999D0)
24697       ELSE IF(NKON.LE.9) THEN
24698 C  direct kinematic 2
24699         X1 = MIN(Y1,0.999999999999D0)
24700         X2 = 1.D0
24701       ELSE
24702 C  double direct kinematic
24703         X1 = 1.D0
24704         X2 = 1.D0
24705       ENDIF
24706       W   = SQRT(MAX(TINY,1.D0-AH/Y1))
24707       V   =-0.5D0+W*(Z(3)-0.5D0)
24708       U   =-(1.D0+V)
24709       PT  = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24710
24711 C  set hard scale  QQ  for alpha and partondistr.
24712       IF     ( NQQAL.EQ.1 ) THEN
24713         QQAL = AQQAL*PT*PT
24714       ELSEIF ( NQQAL.EQ.2 ) THEN
24715         QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24716       ELSEIF ( NQQAL.EQ.3 ) THEN
24717         QQAL = AQQAL*Y1*ECMX*ECMX
24718       ELSEIF ( NQQAL.EQ.4 ) THEN
24719         QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24720       ENDIF
24721       IF     ( NQQPD.EQ.1 ) THEN
24722         QQPD = AQQPD*PT*PT
24723       ELSEIF ( NQQPD.EQ.2 ) THEN
24724         QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24725       ELSEIF ( NQQPD.EQ.3 ) THEN
24726         QQPD = AQQPD*Y1*ECMX*ECMX
24727       ELSEIF ( NQQPD.EQ.4 ) THEN
24728         QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24729       ENDIF
24730 C
24731       IF(NKON.LE.5) THEN
24732         DO 10 N=1,5
24733           F(N) = 0.D0
24734  10     CONTINUE
24735 C  resolved processes
24736         ALPHA1 = PHO_ALPHAS(QQAL,3)
24737         ALPHA2 = ALPHA1
24738         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24739         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24740 C  calculate full distribution FDIS
24741         DO 20 I=1,NF
24742           F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24743           F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24744           F(4) = F(4)+PDA(I)+PDA(-I)
24745           F(5) = F(5)+PDB(I)+PDB(-I)
24746 20      CONTINUE
24747         F(1)   = PDA(0)*PDB(0)
24748         T      = PDA(0)*F(5)+PDB(0)*F(4)
24749         F(5)   = F(4)*F(5)-(F(2)+F(3))
24750         F(4)   = T
24751       ELSE IF(NKON.LE.7) THEN
24752 C  direct processes particle 1
24753         IF(IDPDG1.EQ.22) THEN
24754           ALPHA1 = pho_alphae(QQAL)
24755           CH1 = 4.D0/9.D0
24756           CH2 = 3.D0/9.D0
24757         ELSE IF(IDPDG1.EQ.990) THEN
24758           ALPHA1 = PARMDL(74)
24759           CH1 = 1.D0
24760           CH2 = 0.D0
24761         ELSE
24762           FDIS = -1.D0
24763           RETURN
24764         ENDIF
24765         ALPHA2 = PHO_ALPHAS(QQAL,2)
24766         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24767         F(6) = 0.D0
24768         DO 30 I=1,NF
24769           F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24770  30     CONTINUE
24771         F(7)   = PDB(0)
24772       ELSE IF(NKON.LE.9) THEN
24773 C  direct processes particle 2
24774         ALPHA1 = PHO_ALPHAS(QQAL,1)
24775         IF(IDPDG2.EQ.22) THEN
24776           ALPHA2 = pho_alphae(QQAL)
24777           CH1 = 4.D0/9.D0
24778           CH2 = 3.D0/9.D0
24779         ELSE IF(IDPDG2.EQ.990) THEN
24780           ALPHA2 = PARMDL(74)
24781           CH1 = 1.D0
24782           CH2 = 0.D0
24783         ELSE
24784           FDIS = -1.D0
24785           RETURN
24786         ENDIF
24787         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24788         F(8) = 0.D0
24789         DO 40 I=1,NF
24790           F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24791  40     CONTINUE
24792         F(9)   = PDA(0)
24793       ELSE
24794 C  double direct process
24795         SSR = ECMX*ECMX
24796         IF(IDPDG1.EQ.22) THEN
24797           ALPHA1 = pho_alphae(SSR)
24798         ELSE IF(IDPDG1.EQ.990) THEN
24799           ALPHA1 = PARMDL(74)
24800         ELSE
24801           FDIS = -1.D0
24802           RETURN
24803         ENDIF
24804         IF(IDPDG2.EQ.22) THEN
24805           ALPHA2 = pho_alphae(SSR)
24806         ELSE IF(IDPDG2.EQ.990) THEN
24807           ALPHA2 = PARMDL(74)
24808         ELSE
24809           FDIS = -1.D0
24810           RETURN
24811         ENDIF
24812         F(10) = 1.D0
24813       ENDIF
24814
24815       FDIS   = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24816
24817 C  debug output
24818       IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24819      &  'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24820      &  NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24821
24822       END
24823
24824 *$ CREATE PHO_HARINI.FOR
24825 *COPY PHO_HARINI
24826 CDECK  ID>, PHO_HARINI
24827       SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24828 C**********************************************************************
24829 C
24830 C     initialize calculation of hard cross section
24831 C
24832 C     must not be called during MC generation
24833 C
24834 C***********************************************************************
24835       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24836       SAVE
24837
24838       PARAMETER ( DEPS   = 1.D-10 )
24839
24840 C  input/output channels
24841       INTEGER LI,LO
24842       COMMON /POINOU/ LI,LO
24843 C  event debugging information
24844       INTEGER NMAXD
24845       PARAMETER (NMAXD=100)
24846       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24847      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24848       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24849      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24850 C  model switches and parameters
24851       CHARACTER*8 MDLNA
24852       INTEGER ISWMDL,IPAMDL
24853       DOUBLE PRECISION PARMDL
24854       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24855 C  currently activated parton density parametrizations
24856       CHARACTER*8 PDFNAM
24857       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24858       DOUBLE PRECISION PDFLAM,PDFQ2M
24859       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24860      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24861 C  some constants
24862       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24863       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24864      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24865 C  scale parameters for parton model calculations
24866       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24867       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24868       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24869      &                NQQAL,NQQALI,NQQALF,NQQPD
24870 C  data of c.m. system of Pomeron / Reggeon exchange
24871       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24872       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24873      &                 SIDP,CODP,SIFP,COFP
24874       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24875      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
24876      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
24877 C  obsolete cut-off information
24878       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24879       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24880 C  hard scattering parameters used for most recent hard interaction
24881       INTEGER NFbeta,NF
24882       DOUBLE PRECISION ALQCD2,BQCD
24883       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24884
24885       double precision pho_alphas
24886
24887       CHARACTER*20 RFLAG
24888
24889 C  set local Pomeron c.m. system data
24890       IDPDG1    = IDP1
24891       IDPDG2    = IDP2
24892       PVIRTP(1) = PV1
24893       PVIRTP(2) = PV2
24894 C  initialize PDFs
24895       CALL PHO_ACTPDF(IDPDG1,1)
24896       CALL PHO_ACTPDF(IDPDG2,2)
24897 C  initialize alpha_s calculation
24898       DUMMY = PHO_ALPHAS(0.D0,-4)
24899 C  initialize scales with defaults
24900       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24901         IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24902           AQQAL  = PARMDL(83)
24903           AQQALI = PARMDL(86)
24904           AQQALF = PARMDL(89)
24905           AQQPD  = PARMDL(92)
24906           NQQAL  = IPAMDL(83)
24907           NQQALI = IPAMDL(86)
24908           NQQALF = IPAMDL(89)
24909           NQQPD  = IPAMDL(92)
24910         ELSE
24911           AQQAL  = PARMDL(82)
24912           AQQALI = PARMDL(85)
24913           AQQALF = PARMDL(88)
24914           AQQPD  = PARMDL(91)
24915           NQQAL  = IPAMDL(82)
24916           NQQALI = IPAMDL(85)
24917           NQQALF = IPAMDL(88)
24918           NQQPD  = IPAMDL(91)
24919         ENDIF
24920       ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24921         AQQAL  = PARMDL(82)
24922         AQQALI = PARMDL(85)
24923         AQQALF = PARMDL(88)
24924         AQQPD  = PARMDL(91)
24925         NQQAL  = IPAMDL(82)
24926         NQQALI = IPAMDL(85)
24927         NQQALF = IPAMDL(88)
24928         NQQPD  = IPAMDL(91)
24929       ELSE
24930         AQQAL  = PARMDL(81)
24931         AQQALI = PARMDL(84)
24932         AQQALF = PARMDL(87)
24933         AQQPD  = PARMDL(90)
24934         NQQAL  = IPAMDL(81)
24935         NQQALI = IPAMDL(84)
24936         NQQALF = IPAMDL(87)
24937         NQQPD  = IPAMDL(90)
24938       ENDIF
24939       IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24940       IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24941       IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24942       IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24943       IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24944       IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24945       IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24946       IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24947       AQQAL  = PARMDL(109+IP)
24948       AQQALI = PARMDL(113+IP)
24949       AQQALF = PARMDL(117+IP)
24950       AQQPD  = PARMDL(121+IP)
24951       NQQAL  = IPAMDL(64+IP)
24952       NQQALI = IPAMDL(68+IP)
24953       NQQALF = IPAMDL(72+IP)
24954       NQQPD  = IPAMDL(76+IP)
24955       PTCUT(1) = PARMDL(36)
24956       PTCUT(2) = PARMDL(37)
24957       PTCUT(3) = PARMDL(38)
24958       PTCUT(4) = PARMDL(39)
24959       PTANO(1) = PARMDL(130)
24960       PTANO(2) = PARMDL(131)
24961       PTANO(3) = PARMDL(132)
24962       PTANO(4) = PARMDL(133)
24963       RFLAG = '(energy-independent)'
24964       IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24965
24966 C  write out all settings
24967       IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24968         WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24969      &    PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24970      &    PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24971      &    PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
24972 1050    FORMAT(/,
24973      &    ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24974      &    5X,'particle 1 / particle 2:',2I8,/,
24975      &    5X,'min. PT   :',F7.1,2X,A,/,
24976      &    5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24977      &    5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24978      &    5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24979      &    5X,'max. number of active flavours NF  :',I3,/,
24980      &    5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24981       ENDIF
24982
24983       END
24984
24985 *$ CREATE PHO_HARINT.FOR
24986 *COPY PHO_HARINT
24987 CDECK  ID>, PHO_HARINT
24988       SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24989 C**********************************************************************
24990 C
24991 C     interpolate cross sections and weights for hard scattering
24992 C
24993 C     input:  IPP    particle combination (neg. for add. user cuts)
24994 C             ECM    CMS energy (GeV)
24995 C             P2V1/2 particle virtualities (pos., GeV**2)
24996 C             I1     first subprocess to calculate
24997 C             I2     last subprocess to calculate
24998 C                    <-1  only scales and cutoffs calculated
24999 C             K1     first variable to calculate
25000 C             K2     last variable to calculate
25001 C             MSPOM  cross sections to use for pt distribution
25002 C                    0  reggeon
25003 C                    >0 pomeron
25004 C
25005 C             for K1 < 3 the soft pt distribution is also calculated
25006 C
25007 C     output: interpolated values in HWgx, HSig, Hdpt
25008 C
25009 C***********************************************************************
25010       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25011       SAVE
25012
25013       PARAMETER ( DEPS   = 1.D-15,
25014      &            DEPS2  = 2.D-15 )
25015
25016 C  input/output channels
25017       INTEGER LI,LO
25018       COMMON /POINOU/ LI,LO
25019 C  event debugging information
25020       INTEGER NMAXD
25021       PARAMETER (NMAXD=100)
25022       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25023      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25024       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25025      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25026 C  model switches and parameters
25027       CHARACTER*8 MDLNA
25028       INTEGER ISWMDL,IPAMDL
25029       DOUBLE PRECISION PARMDL
25030       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25031 C  Reggeon phenomenology parameters
25032       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25033      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25034       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25035      &                ALREG,ALREGP,GR(2),B0REG(2),
25036      &                GPPP,GPPR,B0PPP,B0PPR,
25037      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25038 C  parameters of 2x2 channel model
25039       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
25040       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
25041 C  data needed for soft-pt calculation
25042       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
25043       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
25044 C  scale parameters for parton model calculations
25045       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25046       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25047       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25048      &                NQQAL,NQQALI,NQQALF,NQQPD
25049 C  obsolete cut-off information
25050       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25051       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25052 C  event weights and generated cross section
25053       INTEGER IPOWGC,ISWCUT,IVWGHT
25054       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25055       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25056      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25057 C  parameters for DGLAP backward evolution in ISR
25058       INTEGER NFSISR
25059       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
25060       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
25061 C  hard cross sections and MC selection weights
25062       INTEGER Max_pro_2
25063       PARAMETER ( Max_pro_2 = 16 )
25064       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25065      &  MH_acc_1,MH_acc_2
25066       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25067       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25068      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25069      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25070      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25071      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25072 C  interpolation tables for hard cross section and MC selection weights
25073       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25074       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25075       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25076       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25077      &  HQ2a_tab,HQ2b_tab,HEcm_tab
25078       COMMON /POHTAB/
25079      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25080      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25081      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25082      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25083      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25084      &  HEcm_tab(1:Max_tab_E,0:4),
25085      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25086 C  data on most recent hard scattering
25087       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
25088       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
25089      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
25090      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
25091       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
25092      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
25093      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
25094      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
25095      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
25096 C  energy-interpolation table
25097       INTEGER IEETA2
25098       PARAMETER ( IEETA2 = 20 )
25099       INTEGER ISIMAX
25100       DOUBLE PRECISION SIGTAB,SIGECM
25101       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
25102
25103       DOUBLE PRECISION XP,PTS
25104       DIMENSION XP(2),PTS(0:2,2)
25105
25106       INTEGER IV
25107       DIMENSION IV(2)
25108
25109       IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
25110      &    'PHO_HARINT: called with ',
25111      &    'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
25112      &    IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
25113
25114       IP = ABS(IPP)
25115       IF(IPP.GT.0) THEN
25116 C  default minimum bias cutoff
25117         PTCUT(IP) = pho_ptcut(ECM,IP)
25118       ELSE
25119 C  user defined additional cutoff
25120         PTCUT(IP) = HSWCUT(4+IP)
25121       ENDIF
25122       PTWANT = PTCUT(IP)
25123
25124 C  ISR cutoffs
25125       Q2CUT     = MIN(PTWANT**2,PARMDL(125+IP))
25126       Q2MISR(1) = MAX(P2V1,Q2CUT)
25127       Q2MISR(2) = MAX(P2V2,Q2CUT)
25128 C  cutoff for direct photon contribution to photon PDF
25129       PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
25130       PTA1      = PTANO(IP)
25131 C  scales for hard scattering
25132       AQQAL  = PARMDL(109+IP)
25133       AQQALI = PARMDL(113+IP)
25134       AQQALF = PARMDL(117+IP)
25135       AQQPD  = PARMDL(121+IP)
25136       NQQAL  = IPAMDL(64+IP)
25137       NQQALI = IPAMDL(68+IP)
25138       NQQALF = IPAMDL(72+IP)
25139       NQQPD  = IPAMDL(76+IP)
25140       IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
25141      &  'PHO_HARINT: scales:',
25142      &  NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
25143
25144       IF(I2.LT.-1) RETURN
25145
25146       IL = IP
25147       IF(IPP.LT.0) IL = 0
25148
25149 C  double-log interpolation
25150       IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
25151         DO 50 M=I1,I2
25152           Hfac(M) = 0.D0
25153           HWgx(M) = 0.D0
25154           HSig(M) = 0.D0
25155           Hdpt(M) = 0.D0
25156  50     CONTINUE
25157       ELSE
25158         I=1
25159  310    CONTINUE
25160           I = I+1
25161         IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
25162
25163         Ia = 1
25164         Ib = 1
25165         fac = LOG(ECM/HEcm_tab(I-1,IL))
25166      &       /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
25167         do M=I1,I2
25168 C  factor due to phase space integration
25169           XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25170      &      *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
25171      &           /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
25172           XX = EXP(XX)
25173           IF(XX.LT.DEPS2) XX = 0.D0
25174           Hfac(M) = XX
25175 C  max. weight
25176           XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25177      &      *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
25178      &           /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
25179           XX = EXP(XX)
25180           IF(XX.LT.DEPS2) XX = 0.D0
25181           HWgx(M) = XX*1.2D0
25182 C  hard cross section
25183           XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25184      &      *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
25185      &           /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
25186           XX = EXP(XX)
25187           IF(XX.LT.DEPS2) XX = 0.D0
25188           HSig(M) = XX
25189 C  differential hard cross section
25190           XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25191      &      *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
25192      &           /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
25193           XX = EXP(XX)
25194           IF(XX.LT.DEPS2) XX = 0.D0
25195           Hdpt(M) = XX
25196         enddo
25197       ENDIF
25198
25199       IF((K1.LT.3).AND.(K2.GE.3)) THEN
25200 C  cross check
25201         IF((I1.GT.9).OR.(I2.LT.9)) THEN
25202           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
25203      &      'hard cross section not calculated ',I1,I2
25204         ENDIF
25205         SIGH   = HSig(9)
25206         DSIGHP = Hdpt(9)
25207 C  load soft cross sections from interpolation table
25208         IF(ECM.LE.SIGECM(IP,1)) THEN
25209           L1 = 1
25210           L2 = 1
25211         ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
25212           DO 55 I=2,ISIMAX
25213             IF(ECM.LE.SIGECM(IP,I)) GOTO 205
25214  55       CONTINUE
25215  205      CONTINUE
25216           L1 = I-1
25217           L2 = I
25218         ELSE
25219           WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
25220      &      'PHO_HARINT: energy too high (IP,Ecm,Emax)',
25221      &      IP,ECM,SIGECM(IP,ISIMAX)
25222           CALL PHO_PREVNT(-1)
25223           L1 = ISIMAX-1
25224           L2 = ISIMAX
25225         ENDIF
25226         FAC2=0.D0
25227         IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
25228      &                    /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
25229         FAC1=1.D0-FAC2
25230         SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
25231      &         FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
25232
25233         FS = FPS(IP)
25234         FH = FPH(IP)
25235         CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
25236       ENDIF
25237
25238  300  CONTINUE
25239
25240 C  debug output
25241       IF(IDEB(58).GE.15) THEN
25242         WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25243      &    'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25244      &    KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25245         DO 162 M=I1,I2
25246           WRITE(LO,'(5X,2I3,1p,4E12.3)')
25247      &      M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25248  162    CONTINUE
25249       ENDIF
25250
25251       END
25252
25253 *$ CREATE PHO_PTCUT.FOR
25254 *COPY PHO_PTCUT
25255       DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25256 C***********************************************************************
25257 C
25258 C     calculate energy-dependent transverse momentum cutoff
25259 C
25260 C***********************************************************************
25261
25262       IMPLICIT NONE
25263
25264       SAVE
25265
25266       double precision ECM
25267       integer IP
25268
25269 C  input/output channels
25270       INTEGER LI,LO
25271       COMMON /POINOU/ LI,LO
25272 C  event debugging information
25273       INTEGER NMAXD
25274       PARAMETER (NMAXD=100)
25275       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25276      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25277       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25278      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25279 C  model switches and parameters
25280       CHARACTER*8 MDLNA
25281       INTEGER ISWMDL,IPAMDL
25282       DOUBLE PRECISION PARMDL
25283       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25284
25285       pho_ptcut = PARMDL(35+IP)
25286
25287       IF(IPAMDL(7).EQ.1) THEN
25288 C  Bopp et al. type (DPMJET)
25289         pho_ptcut = PARMDL(35+IP)
25290      &             + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25291       ELSE IF(IPAMDL(7).EQ.2) THEN
25292 C  Gribov-Levin-Ryskin type
25293         pho_ptcut = PARMDL(35+IP)
25294      &             + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25295       ENDIF
25296
25297       END
25298
25299 *$ CREATE PHO_HARMCI.FOR
25300 *COPY PHO_HARMCI
25301 CDECK  ID>, PHO_HARMCI
25302       SUBROUTINE PHO_HARMCI(IP,EMAXF)
25303 C**********************************************************************
25304 C
25305 C     initialize MC sampling and calculate hard cross section
25306 C
25307 C     input:  IP       particle combination (neg. number for user cut)
25308 C             EMAXF    maximum CMS energy for
25309 C                      interpolation table in reference to PTCUT(1..4)
25310 C
25311 C***********************************************************************
25312       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25313       SAVE
25314
25315       PARAMETER (DEPS   = 1.D-10,
25316      &           PLARGE = 1.D20 )
25317
25318 C  input/output channels
25319       INTEGER LI,LO
25320       COMMON /POINOU/ LI,LO
25321 C  event debugging information
25322       INTEGER NMAXD
25323       PARAMETER (NMAXD=100)
25324       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25325      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25326       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25327      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25328 C  some constants
25329       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25330       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25331      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25332 C  global event kinematics and particle IDs
25333       INTEGER IFPAP,IFPAB
25334       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25335       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25336 C  data of c.m. system of Pomeron / Reggeon exchange
25337       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25338       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25339      &                 SIDP,CODP,SIFP,COFP
25340       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25341      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25342      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25343 C  model switches and parameters
25344       CHARACTER*8 MDLNA
25345       INTEGER ISWMDL,IPAMDL
25346       DOUBLE PRECISION PARMDL
25347       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25348 C  obsolete cut-off information
25349       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25350       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25351 C  scale parameters for parton model calculations
25352       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25353       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25354       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25355      &                NQQAL,NQQALI,NQQALF,NQQPD
25356 C  names of hard scattering processes
25357       INTEGER Max_pro_1
25358       PARAMETER ( Max_pro_1 = 16 )
25359       CHARACTER*18 PROC
25360       COMMON /POHPRO/ PROC(0:Max_pro_1)
25361 C  hard cross sections and MC selection weights
25362       INTEGER Max_pro_2
25363       PARAMETER ( Max_pro_2 = 16 )
25364       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25365      &  MH_acc_1,MH_acc_2
25366       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25367       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25368      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25369      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25370      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25371      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25372 C  interpolation tables for hard cross section and MC selection weights
25373       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25374       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25375       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25376       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25377      &  HQ2a_tab,HQ2b_tab,HEcm_tab
25378       COMMON /POHTAB/
25379      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25380      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25381      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25382      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25383      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25384      &  HEcm_tab(1:Max_tab_E,0:4),
25385      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25386 C  event weights and generated cross section
25387       INTEGER IPOWGC,ISWCUT,IVWGHT
25388       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25389       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25390      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25391
25392       COMPLEX*16 DSIG
25393       DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25394
25395 C  initialization for all pt cutoffs
25396       I = ABS(IP)
25397       IL = I
25398       IF(IP.LT.0) THEN
25399         IL = 0
25400         PTC = HSWCUT(4+I)
25401       else
25402         PTC = pho_ptcut(parmdl(19),I)
25403       ENDIF
25404
25405 C  skip unassigned PTCUT
25406       IF(PTC.LT.0.5D0) GOTO 1000
25407
25408       IH_Q2a_up(I) = 1
25409       IH_Q2b_up(I) = 1
25410       do ib=1,Max_tab_Q2
25411         do ia=1,Max_tab_Q2
25412           do ie=1,Max_tab_E
25413             do m=-1,Max_pro_2
25414               Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25415               HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25416               HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25417               Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25418             enddo
25419           enddo
25420         enddo
25421       enddo
25422
25423       ELLOW = LOG(2.05*PTC)
25424       DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25425 C  energy too low
25426       IF(DELTA.LE.0.D0) GOTO 1000
25427
25428 C  switch between external particles and Pomeron
25429       IF(I.EQ.4) THEN
25430         IDP1 = 990
25431         PV1  = 0.D0
25432         IDP2 = 990
25433         PV2  = 0.D0
25434       ELSE IF(I.EQ.3) THEN
25435         IDP1 = IFPAP(2)
25436         PV1  = PVIRT(2)
25437         IDP2 = 990
25438         PV2  = 0.D0
25439       ELSE IF(I.EQ.2) THEN
25440         IDP1 = IFPAP(1)
25441         PV1  = PVIRT(1)
25442         IDP2 = 990
25443         PV2  = 0.D0
25444       ELSE
25445         IDP1 = IFPAP(1)
25446         PV1  = PVIRT(1)
25447         IDP2 = IFPAP(2)
25448         PV2  = PVIRT(2)
25449       ENDIF
25450
25451 C  initialize PT scales
25452       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25453         IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25454           FPS(I) = PARMDL(105)
25455           FPH(I) = PARMDL(106)
25456         ELSE
25457           FPS(I) = PARMDL(103)
25458           FPH(I) = PARMDL(104)
25459         ENDIF
25460       ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25461         FPS(I) = PARMDL(103)
25462         FPH(I) = PARMDL(104)
25463       ELSE
25464         FPS(I) = PARMDL(101)
25465         FPH(I) = PARMDL(102)
25466       ENDIF
25467
25468 C  initialize hard scattering
25469       IF(IP.GT.0) THEN
25470         CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25471       ELSE
25472         CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25473       ENDIF
25474
25475 C  energy/virtuality grid
25476       do Ie=1,IH_Ecm_up(IL)
25477         HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25478       enddo
25479       do Ia=1,IH_Q2a_up(IL)
25480         HQ2a_tab(Ia,IL) = 0.D0
25481       enddo
25482       do Ib=1,IH_Q2b_up(IL)
25483         HQ2b_tab(Ib,IL) = 0.D0
25484       enddo
25485
25486 C  initialization for several energies and particle virtualities
25487       do Ie=1,IH_Ecm_up(IL)
25488         do Ia=1,IH_Q2a_up(IL)
25489           do Ib=1,IH_Q2b_up(IL)
25490
25491             EE = HEcm_tab(IE,IL)
25492             Q2a = HQ2a_tab(Ia,IL)
25493             Q2b = HQ2b_tab(Ib,IL)
25494             CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25495             IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25496      &        'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25497      &        PTCUT(I),EE,IDPDG1,IDPDG2
25498             Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25499             CALL PHO_HARFAC(PTCUT(I),EE)
25500             CALL PHO_HARWGX(PTCUT(I),EE)
25501             CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25502             IF(IDEB(8).GE.10) THEN
25503               WRITE(LO,'(1X,A,/,1X,A)')
25504      &          'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25505      &          '------------------------------------------------'
25506               DO M=0,Max_pro_2
25507                 WRITE(LO,'(10X,A,1P2E14.4)')
25508      &            PROC(M),DREAL(DSIG(M)),DSPT(M)
25509               ENDDO
25510             ENDIF
25511
25512 C  store in interpolation tables
25513             Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25514             HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25515             do M=0,Max_pro_2
25516               Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25517               HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25518               HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25519               Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25520             enddo
25521
25522 C  summed quantities
25523             HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25524             Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25525             do M=1,8
25526               IF(MH_pro_on(M,I).GT.0) THEN
25527                 HSig_tab(9,IE,Ia,Ib,IL) =
25528      &            HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25529                 Hdpt_tab(9,IE,Ia,Ib,IL) =
25530      &            Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25531               ENDIF
25532             enddo
25533             HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25534             Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25535             do M=10,14
25536               IF(MH_pro_on(M,I).GT.0) THEN
25537                 HSig_tab(15,IE,Ia,Ib,IL) =
25538      &            HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25539                 Hdpt_tab(15,IE,Ia,Ib,IL) =
25540      &            Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25541               ENDIF
25542             enddo
25543             HSig_tab(0,IE,Ia,Ib,IL) =
25544      &        HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25545             Hdpt_tab(0,IE,Ia,Ib,IL) =
25546      &        Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25547
25548           enddo
25549         enddo
25550       enddo
25551
25552 C  debug output of weights
25553  1000 CONTINUE
25554       IF(IDEB(8).GE.5) THEN
25555         WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25556      &    'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25557      &    IDPDG1,IDPDG2,IP,PTCUT(I),
25558      &    '------------------------------------------'
25559         DO M=-1,Max_pro_2
25560           IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25561           WRITE(LO,'(2X,A,I3,2I7)')
25562      &      'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25563      &      M,IDPDG1,IDPDG2
25564           do k=1,IH_Ecm_up(IL)
25565             do ia=1,IH_Q2a_up(IL)
25566               do ib=1,IH_Q2b_up(IL)
25567                 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25568      &            HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25569      &            Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25570      &            HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25571               enddo
25572             enddo
25573           enddo
25574  512      CONTINUE
25575         ENDDO
25576       ENDIF
25577
25578       END
25579
25580 *$ CREATE PHO_HARXR3.FOR
25581 *COPY PHO_HARXR3
25582 CDECK  ID>, PHO_HARXR3
25583       SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25584 C**********************************************************************
25585 C
25586 C     differential cross section DSIG/(DETAC*DETAD*DPT)
25587 C
25588 C     input:  ECMH     CMS energy
25589 C             PT       parton PT
25590 C             ETAC     pseudorapidity of parton C
25591 C             ETAD     pseudorapidity of parton D
25592 C
25593 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25594 C
25595 C**********************************************************************
25596       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25597       SAVE
25598
25599       PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25600
25601       PARAMETER ( Max_pro_2 = 16 )
25602       COMPLEX*16 DSIGMC
25603       DIMENSION DSIGMC(0:Max_pro_2)
25604       DIMENSION DSIGM(0:Max_pro_2)
25605
25606 C  input/output channels
25607       INTEGER LI,LO
25608       COMMON /POINOU/ LI,LO
25609 C  some constants
25610       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25611       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25612      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25613 C  Reggeon phenomenology parameters
25614       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25615      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25616       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25617      &                ALREG,ALREGP,GR(2),B0REG(2),
25618      &                GPPP,GPPR,B0PPP,B0PPR,
25619      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25620 C  currently activated parton density parametrizations
25621       CHARACTER*8 PDFNAM
25622       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25623       DOUBLE PRECISION PDFLAM,PDFQ2M
25624       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25625      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25626 C  hard scattering parameters used for most recent hard interaction
25627       INTEGER NFbeta,NF
25628       DOUBLE PRECISION ALQCD2,BQCD
25629       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25630 C  scale parameters for parton model calculations
25631       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25632       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25633       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25634      &                NQQAL,NQQALI,NQQALF,NQQPD
25635
25636       DOUBLE PRECISION PHO_ALPHAS
25637       DIMENSION PDA(-6:6),PDB(-6:6)
25638
25639       DO 10 I=1,9
25640         DSIGMC(I) = CMPLX(0.D0,0.D0)
25641         DSIGM(I)  = 0.D0
25642 10    CONTINUE
25643
25644       EC     = EXP(ETAC)
25645       ED     = EXP(ETAD)
25646 C  kinematic conversions
25647       XA     = PT*(EC+ED)/ECMH
25648       XB     = XA/(EC*ED)
25649       IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25650         WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25651         RETURN
25652       ENDIF
25653       SP     = XA*XB*ECMH*ECMH
25654       UP     =-ECMH*PT*EC*XB
25655       UP     = UP/SP
25656       TP     =-(1.D0+UP)
25657       UU     = UP*UP
25658       TT     = TP*TP
25659 C  set hard scale  QQ  for alpha and partondistr.
25660       IF     ( NQQAL.EQ.1 ) THEN
25661         QQAL = AQQAL*PT*PT
25662       ELSEIF ( NQQAL.EQ.2 ) THEN
25663         QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25664       ELSEIF ( NQQAL.EQ.3 ) THEN
25665         QQAL = AQQAL*SP
25666       ELSEIF ( NQQAL.EQ.4 ) THEN
25667         QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25668       ENDIF
25669       IF     ( NQQPD.EQ.1 ) THEN
25670         QQPD = AQQPD*PT*PT
25671       ELSEIF ( NQQPD.EQ.2 ) THEN
25672         QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25673       ELSEIF ( NQQPD.EQ.3 ) THEN
25674         QQPD = AQQPD*SP
25675       ELSEIF ( NQQPD.EQ.4 ) THEN
25676         QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25677       ENDIF
25678
25679       ALPHA  = PHO_ALPHAS(QQAL,3)
25680       FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25681 C  parton distributions (times x)
25682       CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25683       CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25684       S1    = PDA(0)*PDB(0)
25685       S2    = 0.D0
25686       S3    = 0.D0
25687       S4    = 0.D0
25688       S5    = 0.D0
25689       DO 20 I=1,NF
25690         S2  = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25691         S3  = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25692         S4  = S4+PDA(I)+PDA(-I)
25693         S5  = S5+PDB(I)+PDB(-I)
25694 20    CONTINUE
25695 C  partial cross sections (including color and symmetry factors)
25696 C  resolved photon matrix elements (light quarks)
25697       DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25698       DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25699       DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25700       DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25701       DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25702       DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25703       DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25704       DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25705      &           (8.D0/27.D0)/(UP*TP))
25706 C
25707       DSIGM(1) = FACTOR*DSIGM(1)*S1
25708       DSIGM(2) = FACTOR*DSIGM(2)*S2
25709       DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25710       DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25711       DSIGM(5) = FACTOR*DSIGM(5)*S2
25712       DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25713       DSIGM(7) = FACTOR*DSIGM(7)*S3
25714       DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25715 C  complex part
25716       X=ABS(TP-UP)
25717       FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25718 C
25719       DO 50 I=1,8
25720         IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25721         DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25722         DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25723  50   CONTINUE
25724       END
25725
25726 *$ CREATE PHO_HARXR2.FOR
25727 *COPY PHO_HARXR2
25728 CDECK  ID>, PHO_HARXR2
25729       SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25730 C**********************************************************************
25731 C
25732 C     differential cross section DSIG/(DETAC*DPT)
25733 C
25734 C     input:  ECMH     CMS energy
25735 C             PT       parton PT
25736 C             ETAC     pseudorapidity of parton C
25737 C
25738 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25739 C
25740 C**********************************************************************
25741       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25742       SAVE
25743
25744       PARAMETER ( TINY= 1.D-20 )
25745
25746       PARAMETER ( Max_pro_2 = 16 )
25747       COMPLEX*16 DSIGMC
25748       DIMENSION DSIGMC(0:Max_pro_2)
25749
25750 C  input/output channels
25751       INTEGER LI,LO
25752       COMMON /POINOU/ LI,LO
25753 C  integration precision for hard cross sections (obsolete)
25754       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25755       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25756
25757       COMPLEX*16 DSIG1
25758       DIMENSION DSIG1(0:Max_pro_2)
25759       DIMENSION ABSZ(32),WEIG(32)
25760
25761       DO 10 M=1,9
25762         DSIGMC(M) = CMPLX(0.D0,0.D0)
25763         DSIG1(M)  = 0.D0
25764 10    CONTINUE
25765 C
25766       EC  = EXP(ETAC)
25767       ARG = ECMH/PT
25768       IF  ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25769       EDU = LOG(ARG-EC)
25770       EDL =-LOG(ARG-1.D0/EC)
25771       NPOINT = NGAUET
25772       CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25773       DO 30 I=1,NPOINT
25774         CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25775         DO 20 M=1,9
25776           PCTRL= DREAL(DSIG1(M))/TINY
25777           IF( PCTRL.GE.1.D0 ) THEN
25778             DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25779           ENDIF
25780 20      CONTINUE
25781 30    CONTINUE
25782       END
25783
25784 *$ CREATE PHO_HARXD2.FOR
25785 *COPY PHO_HARXD2
25786 CDECK  ID>, PHO_HARXD2
25787       SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25788 C**********************************************************************
25789 C
25790 C     differential cross section DSIG/(DETAC*DPT) for direct processes
25791 C
25792 C     input:  ECMH     CMS energy of scattering system
25793 C             PT       parton PT
25794 C             ETAC     pseudorapidity of parton C
25795 C
25796 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25797 C
25798 C**********************************************************************
25799       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25800       SAVE
25801
25802       PARAMETER ( Max_pro_2 = 16 )
25803       COMPLEX*16 DSIGMC
25804       DIMENSION DSIGMC(0:Max_pro_2)
25805       PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25806
25807 C  input/output channels
25808       INTEGER LI,LO
25809       COMMON /POINOU/ LI,LO
25810 C  model switches and parameters
25811       CHARACTER*8 MDLNA
25812       INTEGER ISWMDL,IPAMDL
25813       DOUBLE PRECISION PARMDL
25814       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25815 C  data of c.m. system of Pomeron / Reggeon exchange
25816       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25817       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25818      &                 SIDP,CODP,SIFP,COFP
25819       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25820      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25821      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25822 C  Reggeon phenomenology parameters
25823       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25824      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25825       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25826      &                ALREG,ALREGP,GR(2),B0REG(2),
25827      &                GPPP,GPPR,B0PPP,B0PPR,
25828      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25829 C  currently activated parton density parametrizations
25830       CHARACTER*8 PDFNAM
25831       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25832       DOUBLE PRECISION PDFLAM,PDFQ2M
25833       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25834      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25835 C  hard scattering parameters used for most recent hard interaction
25836       INTEGER NFbeta,NF
25837       DOUBLE PRECISION ALQCD2,BQCD
25838       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25839 C  some hadron information, will be deleted in future versions
25840       INTEGER NFS
25841       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25842       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25843 C  scale parameters for parton model calculations
25844       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25845       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25846       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25847      &                NQQAL,NQQALI,NQQALF,NQQPD
25848 C  some constants
25849       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25850       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25851      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25852
25853       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25854       DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25855
25856 *     ONE32=1.D0/9.D0
25857 *     TWO32=4.D0/9.D0
25858       DO 10 I=10,13
25859         DSIGMC(I) = CMPLX(0.D0,0.D0)
25860         DSIGM(I) = 0.D0
25861  10   CONTINUE
25862       DSIGMC(15) = CMPLX(0.D0,0.D0)
25863       DSIGM(15) = 0.D0
25864
25865 C  direct particle 1
25866       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25867         EC     = EXP(ETAC)
25868         ED     = ECMH/PT-EC
25869 C  kinematic conversions
25870         XA     = 1.D0
25871         XB     = 1.D0/(EC*ED)
25872         IF ( XB.GE.1.D0 ) THEN
25873           WRITE(LO,'(/1X,A,2E12.4)')
25874      &      'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25875           RETURN
25876         ENDIF
25877         SP     = XA*XB*ECMH*ECMH
25878         UP     =-ECMH*PT*EC*XB
25879         UP     = UP/SP
25880         TP     =-(1.D0+UP)
25881         UU     = UP*UP
25882         TT     = TP*TP
25883 C  set hard scale  QQ  for alpha and partondistr.
25884         IF     ( NQQAL.EQ.1 ) THEN
25885           QQAL = AQQAL*PT*PT
25886         ELSEIF ( NQQAL.EQ.2 ) THEN
25887           QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25888         ELSEIF ( NQQAL.EQ.3 ) THEN
25889           QQAL = AQQAL*SP
25890         ELSEIF ( NQQAL.EQ.4 ) THEN
25891           QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25892         ENDIF
25893         IF     ( NQQPD.EQ.1 ) THEN
25894           QQPD = AQQPD*PT*PT
25895         ELSEIF ( NQQPD.EQ.2 ) THEN
25896           QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25897         ELSEIF ( NQQPD.EQ.3 ) THEN
25898           QQPD = AQQPD*SP
25899         ELSEIF ( NQQPD.EQ.4 ) THEN
25900           QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25901         ENDIF
25902
25903         ALPHA2 = PHO_ALPHAS(QQAL,2)
25904         IF(IDPDG1.EQ.22) THEN
25905           ALPHA1 = pho_alphae(QQAL)
25906         ELSE IF(IDPDG1.EQ.990) THEN
25907           ALPHA1 = PARMDL(74)
25908         ENDIF
25909         FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25910 C  parton distribution (times x)
25911         CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25912         S1    = PDB(0)
25913 C  charge counting
25914         S2    = 0.D0
25915         S3    = 0.D0
25916         IF(IDPDG1.EQ.22) THEN
25917           DO 20 I=1,NF
25918 *           IF(MOD(I,2).EQ.0) THEN
25919 *             S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25920 *             S3 = S3 + TWO32
25921 *           ELSE
25922 *             S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25923 *             S3 = S3 + ONE32
25924 *           ENDIF
25925             S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25926             S3 = S3 + Q_ch2(I)
25927  20       CONTINUE
25928         ELSE IF(IDPDG1.EQ.990) THEN
25929           DO 25 I=1,NF
25930             S2 = S2 + PDB(I)+PDB(-I)
25931  25       CONTINUE
25932           S3 = NF
25933         ENDIF
25934 C  partial cross sections (including color and symmetry factors)
25935 C  direct photon matrix elements
25936         DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25937         DSIGM(11) = (UU+TT)/(UP*TP)
25938 C
25939         DSIGM(10) = FACTOR*DSIGM(10)*S2
25940         DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25941 C  complex part
25942         X=ABS(TP-UP)
25943         FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25944 C
25945         DO 50 I=10,11
25946           IF(DSIGM(I).LT.0.D0) THEN
25947             WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25948      &        'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25949             DSIGM(I) = 0.D0
25950           ENDIF
25951           DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25952           DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25953  50     CONTINUE
25954       ENDIF
25955 C
25956 C  direct particle 2
25957       IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25958         EC     = EXP(ETAC)
25959         ED     = 1.D0/(ECMH/PT-1.D0/EC)
25960 C  kinematic conversions
25961         XA     = PT*(EC+ED)/ECMH
25962         XB     = 1.D0
25963         IF ( XA.GE.1.D0 ) THEN
25964           WRITE(LO,'(/1X,A,2E12.4)')
25965      &      'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25966           RETURN
25967         ENDIF
25968         SP     = XA*XB*ECMH*ECMH
25969         UP     =-ECMH*PT*EC*XB
25970         UP     = UP/SP
25971         TP     =-(1.D0+UP)
25972         UU     = UP*UP
25973         TT     = TP*TP
25974 C  set hard scale  QQ  for alpha and partondistr.
25975         IF     ( NQQAL.EQ.1 ) THEN
25976           QQAL = AQQAL*PT*PT
25977         ELSEIF ( NQQAL.EQ.2 ) THEN
25978           QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25979         ELSEIF ( NQQAL.EQ.3 ) THEN
25980           QQAL = AQQAL*SP
25981         ELSEIF ( NQQAL.EQ.4 ) THEN
25982           QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25983         ENDIF
25984         IF     ( NQQPD.EQ.1 ) THEN
25985           QQPD = AQQPD*PT*PT
25986         ELSEIF ( NQQPD.EQ.2 ) THEN
25987           QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25988         ELSEIF ( NQQPD.EQ.3 ) THEN
25989           QQPD = AQQPD*SP
25990         ELSEIF ( NQQPD.EQ.4 ) THEN
25991           QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25992         ENDIF
25993
25994         ALPHA1 = PHO_ALPHAS(QQAL,1)
25995         IF(IDPDG2.EQ.22) THEN
25996           ALPHA2 = pho_alphae(QQAL)
25997         ELSE IF(IDPDG2.EQ.990) THEN
25998           ALPHA2 = PARMDL(74)
25999         ENDIF
26000         FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
26001 C  parton distribution (times x)
26002         CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
26003         S1    = PDA(0)
26004 C  charge counting
26005         S2    = 0.D0
26006         S3    = 0.D0
26007         IF(IDPDG2.EQ.22) THEN
26008           DO 70 I=1,NF
26009 *           IF(MOD(I,2).EQ.0) THEN
26010 *             S2 = S2 + (PDA(I)+PDA(-I))*TWO32
26011 *             S3 = S3 + TWO32
26012 *           ELSE
26013 *             S2 = S2 + (PDA(I)+PDA(-I))*ONE32
26014 *             S3 = S3 + ONE32
26015 *           ENDIF
26016             S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
26017             S3 = S3 + Q_ch2(I)
26018  70       CONTINUE
26019         ELSE IF(IDPDG2.EQ.990) THEN
26020           DO 75 I=1,NF
26021             S2 = S2 + PDA(I)+PDA(-I)
26022  75       CONTINUE
26023           S3 = NF
26024         ENDIF
26025 C  partial cross sections (including color and symmetry factors)
26026 C  direct photon matrix elements
26027         DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
26028         DSIGM(13) = (UU+TT)/(UP*TP)
26029 C
26030         DSIGM(12) = FACTOR*DSIGM(12)*S2
26031         DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
26032 C  complex part
26033         X=ABS(TP-UP)
26034         FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
26035 C
26036         DO 80 I=12,13
26037           IF(DSIGM(I).LT.0.D0) THEN
26038             WRITE(LO,'(1X,A,I3,1P,2E12.4)')
26039      &        'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
26040             DSIGM(I) = 0.D0
26041           ENDIF
26042           DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
26043           DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
26044  80     CONTINUE
26045       ENDIF
26046       END
26047
26048 *$ CREATE PHO_HARXPT.FOR
26049 *COPY PHO_HARXPT
26050 CDECK  ID>, PHO_HARXPT
26051       SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
26052 C**********************************************************************
26053 C
26054 C     differential cross section DSIG/DPT
26055 C
26056 C     input:  ECMH     CMS energy of scattering system
26057 C             PT       parton PT
26058 C             IPRO     1  resolved processes
26059 C                      2  direct processes
26060 C                      3  resolved and direct processes
26061 C
26062 C     output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
26063 C
26064 C**********************************************************************
26065       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26066       SAVE
26067
26068       PARAMETER ( Max_pro_2 = 16 )
26069       COMPLEX*16 DSIGMC
26070       DIMENSION  DSIGMC(0:Max_pro_2)
26071       PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
26072
26073 C  input/output channels
26074       INTEGER LI,LO
26075       COMMON /POINOU/ LI,LO
26076 C  some constants
26077       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26078       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26079      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26080 C  model switches and parameters
26081       CHARACTER*8 MDLNA
26082       INTEGER ISWMDL,IPAMDL
26083       DOUBLE PRECISION PARMDL
26084       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26085 C  data of c.m. system of Pomeron / Reggeon exchange
26086       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26087       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26088      &                 SIDP,CODP,SIFP,COFP
26089       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26090      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
26091      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
26092 C  Reggeon phenomenology parameters
26093       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26094      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26095       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26096      &                ALREG,ALREGP,GR(2),B0REG(2),
26097      &                GPPP,GPPR,B0PPP,B0PPR,
26098      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26099 C  integration precision for hard cross sections (obsolete)
26100       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26101       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26102 C  hard scattering parameters used for most recent hard interaction
26103       INTEGER NFbeta,NF
26104       DOUBLE PRECISION ALQCD2,BQCD
26105       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26106 C  some hadron information, will be deleted in future versions
26107       INTEGER NFS
26108       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26109       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26110
26111       double precision pho_alphae
26112
26113       COMPLEX*16 DSIG1
26114       DIMENSION  DSIG1(0:Max_pro_2)
26115       DIMENSION ABSZ(32),WEIG(32)
26116
26117       DO 10 M=0,Max_pro_2
26118         DSIGMC(M) = CMPLX(0.D0,0.D0)
26119         DSIG1(M)  = CMPLX(0.D0,0.D0)
26120  10   CONTINUE
26121
26122 C  resolved and direct processes
26123       AMT = 2.D0*PT/ECMH
26124       IF ( AMT.GE.1.D0 ) RETURN
26125       ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
26126       ECL = -ECU
26127       NPOINT = NGAUET
26128       CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
26129       DO 30 I=1,NPOINT
26130         DSIG1(9)  = CMPLX(0.D0,0.D0)
26131         DSIG1(15) = CMPLX(0.D0,0.D0)
26132         IF(IPRO.EQ.1) THEN
26133           CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
26134         ELSE IF(IPRO.EQ.2) THEN
26135           CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
26136         ELSE
26137           CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
26138           CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
26139         ENDIF
26140         DO 20 M=1,Max_pro_2
26141           DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
26142  20     CONTINUE
26143  30   CONTINUE
26144
26145 C  direct processes
26146       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26147      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26148         FAC = 0.D0
26149         SS = ECMH*ECMH
26150         ALPHAE = pho_alphae(SS)
26151         DO 300 I=1,NF
26152           IF(IDPDG1.EQ.22) THEN
26153 *           F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26154             F1 = Q_ch2(I)*ALPHAE
26155           ELSE
26156             F1 = PARMDL(74)
26157           ENDIF
26158           IF(IDPDG2.EQ.22) THEN
26159 *           F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26160             F2 = Q_ch2(I)*ALPHAE
26161           ELSE
26162             F2 = PARMDL(74)
26163           ENDIF
26164           FAC = FAC+F1*F2*3.D0
26165  300    CONTINUE
26166 C  direct cross sections
26167         ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
26168         T1 = -SS/2.D0*(1.D0+ZZ)
26169         T2 = -SS/2.D0*(1.D0-ZZ)
26170         XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
26171 C  hadronic part
26172         DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
26173
26174 C  leptonic part (e, mu, tau)
26175         DSIGMC(16) = 0.D0
26176         IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26177           DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
26178 C  simulation of tau together with quarks
26179           IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26180         ENDIF
26181       ENDIF
26182
26183       DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
26184       DSIGMC(0)  = DSIGMC(9)+DSIGMC(15)
26185
26186       END
26187
26188 *$ CREATE PHO_HARXTO.FOR
26189 *COPY PHO_HARXTO
26190 CDECK  ID>, PHO_HARXTO
26191       SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
26192 C**********************************************************************
26193 C
26194 C     total hard cross section (perturbative QCD, Parton Model)
26195 C
26196 C     input:  ECMH     CMS energy of scattering system
26197 C             PTCUTR   PT cutoff for resolved processes
26198 C             PTCUTD   PT cutoff for direct processes (photon, Pomeron)
26199 C
26200 C     output: DSIGMC(0:MARPR2) cross sections for given cutoff
26201 C             DSDPTC(0:MARPR2) differential cross sections at cutoff
26202 C
26203 C     note:  COMPLEX*16          DSIGMC
26204 C            DOUBLE PRECISION    DSDPTC
26205 C
26206 C**********************************************************************
26207       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26208       SAVE
26209
26210       PARAMETER ( Max_pro_2 = 16 )
26211       COMPLEX*16 DSIGMC
26212       DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
26213
26214 C  input/output channels
26215       INTEGER LI,LO
26216       COMMON /POINOU/ LI,LO
26217 C  model switches and parameters
26218       CHARACTER*8 MDLNA
26219       INTEGER ISWMDL,IPAMDL
26220       DOUBLE PRECISION PARMDL
26221       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26222 C  data of c.m. system of Pomeron / Reggeon exchange
26223       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26224       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26225      &                 SIDP,CODP,SIFP,COFP
26226       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26227      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
26228      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
26229 C  Reggeon phenomenology parameters
26230       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26231      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26232       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26233      &                ALREG,ALREGP,GR(2),B0REG(2),
26234      &                GPPP,GPPR,B0PPP,B0PPR,
26235      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26236 C  some constants
26237       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26238       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26239      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26240 C  integration precision for hard cross sections (obsolete)
26241       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26242       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26243 C  some hadron information, will be deleted in future versions
26244       INTEGER NFS
26245       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26246       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26247 C  hard scattering parameters used for most recent hard interaction
26248       INTEGER NFbeta,NF
26249       DOUBLE PRECISION ALQCD2,BQCD
26250       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26251
26252       double precision pho_alphae
26253
26254       COMPLEX*16 DSIG1
26255       DIMENSION DSIG1(0:Max_pro_2)
26256       DIMENSION ABSZ(32),WEIG(32)
26257
26258       DATA FAC / 3.0D0 /
26259
26260       DO 10 M=0,Max_pro_2
26261         DSIGMC(M)= CMPLX(0.D0,0.D0)
26262  10   CONTINUE
26263       EEC=ECMH/2.001D0
26264 C
26265       IF ( PTCUTR.GE.EEC ) GOTO 100
26266 C
26267 C  integration for resolved processes
26268       PTMIN  = PTCUTR
26269       PTMAX  = MIN(FAC*PTMIN,EEC)
26270       NPOINT = NGAUP1
26271       CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26272       DO 60 M=1,9
26273         DSDPTC(M) = DREAL(DSIG1(M))
26274  60   CONTINUE
26275       DSIGH   = DREAL(DSIG1(9))
26276       PTMXX  = 0.95D0*PTMAX
26277       CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26278       DSIGL  = DREAL(DSIG1(9))
26279       EX     = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26280       EX1    = 1.0D0-EX
26281       DO 50 K=1,2
26282         IF ( PTMIN.GE.PTMAX ) GOTO 40
26283         RL   = PTMIN**EX1
26284         RU   = PTMAX**EX1
26285         CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26286         DO 30 I=1,NPOINT
26287           R  = ABSZ(I)
26288           PT = R**(1.0D0/EX1)
26289           CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26290           F  = WEIG(I)*PT/(R*EX1)
26291           DO 20 M=1,9
26292             DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26293  20       CONTINUE
26294  30     CONTINUE
26295  40     PTMIN  = PTMAX
26296         PTMAX  = EEC
26297         NPOINT = NGAUP2
26298  50   CONTINUE
26299  100  CONTINUE
26300       DSIGMC(0) = DSIGMC(9)
26301       DSDPTC(0) = DSDPTC(9)
26302 C
26303 C  integration for direct processes
26304       IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26305 C
26306       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26307      &   .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26308         PTMIN  = PTCUTD
26309         PTMAX  = MIN(FAC*PTMIN,EEC)
26310         NPOINT = NGAUP1
26311         CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26312         IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26313         DO 160 M=10,16
26314           DSDPTC(M) = DREAL(DSIG1(M))
26315  160    CONTINUE
26316         DSIGH   = DREAL(DSIG1(15)-DSIG1(14))
26317         PTMXX  = 0.95D0*PTMAX
26318         CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26319         DSIGL  = DREAL(DSIG1(15)-DSIG1(14))
26320         EX     = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26321         EX1    = 1.0D0-EX
26322         DO 150 K=1,2
26323           IF ( PTMIN.GE.PTMAX ) GOTO 140
26324           RL   = PTMIN**EX1
26325           RU   = PTMAX**EX1
26326           CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26327           DO 130 I=1,NPOINT
26328             R  = ABSZ(I)
26329             PT = R**(1.0D0/EX1)
26330             CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26331             F  = WEIG(I)*PT/(R*EX1)
26332             DO 120 M=10,15
26333               DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26334  120        CONTINUE
26335  130      CONTINUE
26336  140      PTMIN  = PTMAX
26337           PTMAX  = EEC
26338           NPOINT = NGAUP2
26339  150    CONTINUE
26340       ENDIF
26341 C
26342  170  CONTINUE
26343 C
26344 C  double direct process
26345       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26346      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26347         FACC = 0.D0
26348         SS = ECMH*ECMH
26349         ALPHAE = pho_alphae(SS)
26350         DO 300 I=1,NF
26351           IF(IDPDG1.EQ.22) THEN
26352 *           F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26353             F1 = Q_ch2(I)*ALPHAE
26354           ELSE
26355             F1 = PARMDL(74)
26356           ENDIF
26357           IF(IDPDG2.EQ.22) THEN
26358 *           F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26359             F2 = Q_ch2(I)*ALPHAE
26360           ELSE
26361             F2 = PARMDL(74)
26362           ENDIF
26363           FACC = FACC + F1*F2*3.D0
26364  300    CONTINUE
26365
26366         ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26367         R  = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26368 C  hadronic cross section
26369         DSIGMC(14) = R*FACC*AKFAC
26370 C  leptonic cross section
26371         IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26372           DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26373 C  simulation of tau together with quarks
26374           IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26375           DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26376         ELSE
26377           DSIGMC(16) = CMPLX(0.D0,0.D0)
26378         ENDIF
26379 C  sum of direct part
26380         DSIGMC(15) = CMPLX(0.D0,0.D0)
26381         DO 400 I=10,14
26382           DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26383  400    CONTINUE
26384       ENDIF
26385 C total sum (hadronic)
26386       DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26387       DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26388
26389       END
26390
26391 *$ CREATE PHO_HARISR.FOR
26392 *COPY PHO_HARISR
26393 CDECK  ID>, PHO_HARISR
26394       SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26395      &  XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26396 C********************************************************************
26397 C
26398 C     initial state radiation according to DGLAP evolution equations
26399 C     (backward evolution, no spin effects)
26400 C
26401 C     input:    IHPOM     index of hard Pomeron
26402 C                         negative: delete all previous entries
26403 C               P1,P2     4 momenta of hard scattered final partons
26404 C                         (in CMS of hard scattering)
26405 C               IPF1,2    flavours of final partons
26406 C               IPA1,2    flavours of initial partons
26407 C               IV1,2     valence quark labels (0/1)
26408 C               Q2H       momentum transfer (squared, positive)
26409 C               XH1,XH2   x values of initial partons
26410 C               XHMAX1,2  max. x values allowed
26411 C
26412 C     output:   all emitted partons in /POPISR/, final state
26413 C               partons are the first two entries
26414 C               shower evolution traced in /PODGL1/
26415 C               IPB1,2    flavours of new initial partons
26416 C               XISR1,2   x values of new initial partons
26417 C               IVO1,2    valence quark labels (0/1)
26418 C
26419 C     attention: quark numbering according to PDG convention,
26420 C                but 0 for gluons
26421 C
26422 C********************************************************************
26423       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26424       SAVE
26425
26426       PARAMETER (RHOMAS =  0.766D0,
26427      &           DEPS   =  1.D-10,
26428      &           TINY   =  1.D-10)
26429
26430       DIMENSION P1(4),P2(4)
26431
26432 C  input/output channels
26433       INTEGER LI,LO
26434       COMMON /POINOU/ LI,LO
26435 C  event debugging information
26436       INTEGER NMAXD
26437       PARAMETER (NMAXD=100)
26438       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26439      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26440       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26441      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26442 C  internal rejection counters
26443       INTEGER NMXJ
26444       PARAMETER (NMXJ=60)
26445       CHARACTER*10 REJTIT
26446       INTEGER IFAIL
26447       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26448 C  model switches and parameters
26449       CHARACTER*8 MDLNA
26450       INTEGER ISWMDL,IPAMDL
26451       DOUBLE PRECISION PARMDL
26452       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26453 C  data of c.m. system of Pomeron / Reggeon exchange
26454       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26455       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26456      &                 SIDP,CODP,SIFP,COFP
26457       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26458      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
26459      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
26460 C  some hadron information, will be deleted in future versions
26461       INTEGER NFS
26462       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26463       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26464 C  currently activated parton density parametrizations
26465       CHARACTER*8 PDFNAM
26466       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26467       DOUBLE PRECISION PDFLAM,PDFQ2M
26468       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26469      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26470 C  scale parameters for parton model calculations
26471       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26472       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26473       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26474      &                NQQAL,NQQALI,NQQALF,NQQPD
26475 C  parameters for DGLAP backward evolution in ISR
26476       INTEGER NFSISR
26477       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26478       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26479 C  initial state parton radiation (internal part)
26480       INTEGER MXISR3,MXISR4
26481       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26482       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26483       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26484       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26485      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26486      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
26487      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26488 C  some constants
26489       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26490       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26491      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26492 C  particles created by initial state evolution
26493       INTEGER MXISR1,MXISR2
26494       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26495       INTEGER IFLISR,IPOISR,IMXISR
26496       DOUBLE PRECISION PHISR
26497       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26498      &                IPOISR(2,2,MXISR2),IMXISR(2)
26499
26500       DOUBLE PRECISION PYP,EER,THER,QMAXR
26501       INTEGER PYK
26502
26503       DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26504      &          WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26505      &          IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26506
26507       IREJ = 0
26508       NTRY = 1000
26509       NITER = 0
26510 C  debug output
26511       IF(IDEB(79).GE.10) THEN
26512         WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26513      &    'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26514      &    KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26515       ENDIF
26516       IF(IHPOM.EQ.0) RETURN
26517 C
26518  10   CONTINUE
26519       NACC = 0
26520       IDMO(1) = IDPDG1
26521       IDMO(2) = IDPDG2
26522 C
26523 C  copy final state partons to local fields
26524       IHIDX = ABS(IHPOM)
26525
26526       IF(IHIDX.GT.MXISR2) THEN
26527         WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26528      &    '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26529      &    IHIDX,MXISR2
26530         IREJ = 1
26531       ENDIF
26532
26533       DO 50 K=1,2
26534         IF(IHPOM.LT.0) IMXISR(K) = 0
26535         IPOISR(K,1,IHIDX) = IMXISR(K)+1
26536         IPAL(K) = IPOISR(K,1,IHIDX)
26537  50   CONTINUE
26538       DO 55 I=1,4
26539         PHISR(1,I,IPAL(1)) = P1(I)
26540         PHISR(2,I,IPAL(2)) = P2(I)
26541  55   CONTINUE
26542       IFLISR(1,IPAL(1)) = IPF1
26543       IFLISR(2,IPAL(2)) = IPF2
26544 C
26545 C  check limitations, initialize /PODGL1/
26546       IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26547         NEXT(1) = 1
26548         Q2SH(1,1) = Q2H
26549       ELSE
26550         NEXT(1) = 0
26551         Q2SH(1,1) = 0.D0
26552       ENDIF
26553       IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26554         NEXT(2) = 1
26555         Q2SH(2,1) = Q2H
26556       ELSE
26557         NEXT(2) = 0
26558         Q2SH(2,1) = 0.D0
26559       ENDIF
26560 C
26561       ISH(1) = 1
26562       ISH(2) = 1
26563       XPSH(1,1) = XH1
26564       XPSH(2,1) = XH2
26565 C
26566       IFL1(1,1) = IPA1
26567       IVAL(1)   = IV1
26568       IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26569       IFL1(2,1) = IPA2
26570       IVAL(2)   = IV2
26571       IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26572 C
26573       IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26574      &  'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26575       IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26576 C
26577 C  initialize parton shower loop
26578       B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26579       AL2ISR(1) = PDFLAM(1)
26580       AL2ISR(2) = PDFLAM(2)
26581       XHMA(1) = XHMAX1
26582       XHMA(2) = XHMAX2
26583       XHMI(1) = PMISR(1)/PCMP
26584       XHMI(2) = PMISR(2)/PCMP
26585       ZPSH(1,1) = 1.D0
26586       ZPSH(2,1) = 1.D0
26587       SHAT1 = XH1*XH2*ECMP**2
26588       IF(IPAMDL(109).EQ.1) THEN
26589         PT2SH(1,1) = Q2H
26590       ELSE
26591         PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26592       ENDIF
26593       PT2SH(2,1) = PT2SH(1,1)
26594       IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26595       IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26596       THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26597       THSH(2,1) = THSH(1,1)
26598       IFANO(1) = 0
26599       IFANO(2) = 0
26600       ZZ = 1.D0
26601       IF(IREJ.NE.0) GOTO 800
26602 C
26603 C  main generation loop
26604 C -------------------------------------------------
26605  100  CONTINUE
26606 C  choose parton side to become solved
26607         IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26608           IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26609             IP = 1
26610           ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26611             IP = 2
26612           ELSE
26613             IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26614           ENDIF
26615         ELSE IF(NEXT(1).EQ.1) THEN
26616           IP = 1
26617         ELSE IF(NEXT(2).EQ.1) THEN
26618           IP = 2
26619         ELSE
26620           GOTO 800
26621         ENDIF
26622         INDX = ISH(IP)
26623 C  INDX now parton position of parton to become solved
26624 C  IP   now side to be treated
26625         XP = XPSH(IP,INDX)
26626         Q2P = Q2SH(IP,INDX)
26627         PT2 = PT2SH(IP,INDX)
26628         IFLB = IFL1(IP,INDX)
26629 C  check available x
26630         XMIP = XHMI(IP)
26631 C  cutoff by x limitation: no further development
26632         IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26633           NEXT(IP) = 0
26634           Q2SH(IP,INDX) = 0.D0
26635           IF(IDEB(79).GE.17) THEN
26636             WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26637      &        'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26638      &        XP,XMIP,XHMA(IP),IP,INDX
26639           ENDIF
26640           GOTO 100
26641         ENDIF
26642 C  initial value of evolution variable t
26643         TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26644         DO 110 I=-NFSISR,NFSISR
26645           WGGAP(I) = 0.D0
26646           WGPDF(I) = 0.D0
26647  110    CONTINUE
26648 C  DGLAP weights
26649         ZMIN = XP/XHMA(IP)
26650         ZMAX = XP/(XP+XMIP)
26651         CF = 4./3.
26652 C  q --> q g, g --> g g
26653         IF(IFLB.EQ.0) THEN
26654           WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26655      &      +2.D0*LOG(ZMAX/ZMIN))
26656           DO 120 I=1,NFSISR
26657             WGGAP(I)  = WGGAP(0)
26658             WGGAP(-I) = WGGAP(0)
26659  120      CONTINUE
26660           WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26661      &      -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26662 C  q --> g q, g --> q qb
26663         ELSE IF(ABS(IFLB).LE.6) THEN
26664           WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26665      &      -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26666           IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26667      &      -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26668         ELSE
26669           WRITE(LO,'(/1X,A,I7)')
26670      &      'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26671           CALL PHO_ABORT
26672         ENDIF
26673 C  anomalous/resolved evolution
26674         IPDFC = 0
26675         IF(IPAMDL(110).GE.1) THEN
26676           IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26677      &       .AND.(IFLB.NE.21)) THEN
26678             WGDIR = 0.D0
26679             IF(NQQALI.EQ.1) THEN
26680               SCALE2 = PT2*AQQPD
26681             ELSE
26682               SCALE2 = Q2P*AQQPD
26683             ENDIF
26684             CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26685             IPDFC = 1
26686             CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26687             XI = DT_RNDM(XP)*PD1(IFLB)
26688             IF(WGDIR.GT.XI) THEN
26689 C  debug output
26690               IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26691      &          'PHO_HARISR: ',
26692      &          'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26693      &          WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26694               Q2SH(IP,INDX) = 0.D0
26695               NEXT(IP) = 0
26696               IFANO(IP) = INDX
26697               GOTO 100
26698             ENDIF
26699           ENDIF
26700         ENDIF
26701 C
26702 C  rejection loop for z,t sampling
26703 C ------------------------------------
26704  200    CONTINUE
26705           NITER = NITER+1
26706           IF(NITER.GE.NTRY) THEN
26707             WRITE(LO,'(1X,A,2I6)')
26708      &        'PHO_HARISR: too many rejections',NITER,NTRY
26709             CALL PHO_PREVNT(-1)
26710 C  clean up event
26711             IREJ = 1
26712             GOTO 10
26713           ENDIF
26714 C  PDF weights
26715           IF(IPDFC.EQ.0) THEN
26716             IF(NQQALI.EQ.1) THEN
26717               SCALE2 = PT2*AQQPD
26718             ELSE
26719               SCALE2 = Q2P*AQQPD
26720             ENDIF
26721             CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26722           ENDIF
26723           IPDFC = 0
26724 C
26725           WGTOT = 0.D0
26726           DO 210 I=-NFSISR,NFSISR
26727             WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26728             WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26729  210      CONTINUE
26730 C
26731  215      CONTINUE
26732 C  sample new t value
26733           TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26734           Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26735 C  debug output
26736           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26737      &      'PHO_HARISR: pre-selected Q2:',Q2NEW
26738 C  compare to limits
26739           IF(Q2NEW.LT.Q2MISR(IP)) THEN
26740             Q2SH(IP,INDX) = 0.D0
26741             NEXT(IP) = 0
26742             IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26743      &        'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26744      &        Q2NEW,Q2MISR(IP),IP,INDX
26745             GOTO 100
26746           ENDIF
26747           Q2SH(IP,INDX) = Q2NEW
26748           TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26749 C  selection of flavours
26750           XI = WGTOT*DT_RNDM(TT)
26751           IFLA = -NFSISR-1
26752  220      CONTINUE
26753             IFLA = IFLA+1
26754             XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26755           IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26756 C  debug output
26757           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26758      &      'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26759 C  selection of z
26760           CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26761 C  debug output
26762           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26763      &      'PHO_HARISR: pre-selected ZZ',ZZ
26764 C  angular ordering
26765           THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26766           IF(THETA.GT.THSH(IP,INDX)) THEN
26767             IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26768      &        'PHO_HARISR: reject by angle (NEW/OLD)',
26769      &        THETA,THSH(IP,INDX)
26770             GOTO 215
26771           ENDIF
26772 C  rejection weight given by new PDFs
26773           XNEW = XP/ZZ
26774           PT2NEW = Q2NEW*(1.D0-ZZ)
26775           IF(NQQALI.EQ.1) THEN
26776             SCALE2 = PT2NEW*AQQPD
26777           ELSE
26778             SCALE2 = Q2NEW*AQQPD
26779           ENDIF
26780           IF(SCALE2.LT.Q2MISR(IP)) THEN
26781             Q2SH(IP,INDX) = 0.D0
26782             NEXT(IP) = 0
26783             IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26784      &        'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26785      &        Q2NEW,Q2MISR(IP),IP,INDX
26786             GOTO 100
26787           ENDIF
26788           CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26789           IF(PD2(IFLA).LT.1.D-10) GOTO 200
26790           CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26791           PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26792           WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26793           IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26794      &      /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26795           IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26796             WRITE(LO,'(1X,A,E12.3)')
26797      &        'PHO_HARISR: final weight:',WGF
26798             WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26799      &      'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26800           ENDIF
26801         IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26802
26803         IF(IDEB(79).GE.15) THEN
26804           WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26805      &      'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26806      &      IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26807         ENDIF
26808
26809         IF(INDX.GE.MXISR3) THEN
26810           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26811      &      '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26812           IREJ = 1
26813           RETURN
26814         ENDIF
26815
26816 C  branching accepted, registration
26817         Q2SH(IP,INDX) = Q2NEW
26818         PT2SH(IP,INDX) = PT2NEW
26819         ZPSH(IP,INDX) = ZZ
26820         IFL2(IP,INDX) = IFLA-IFLB
26821         Q2SH(IP,INDX+1) = Q2NEW
26822         PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26823         XPSH(IP,INDX+1) = XNEW
26824         THSH(IP,INDX+1) = THETA
26825         IFL1(IP,INDX+1) = IFLA
26826         ISH(IP) = ISH(IP)+1
26827
26828         NACC = NACC+1
26829
26830         IF(NACC.GT.MXISR4) THEN
26831           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26832      &      '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26833           IREJ = 1
26834           RETURN
26835         ENDIF
26836
26837         SHAT(NACC) = SHAT1
26838         IBRA(1,NACC) = IP
26839         IBRA(2,NACC) = INDX
26840         SHAT1 = SHAT1/ZZ
26841
26842 C  generation of next branching
26843       IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26844
26845  800  CONTINUE
26846
26847 C  new initial flavours, x values
26848       IPB1 = IFL1(1,ISH(1))
26849       IPB2 = IFL1(2,ISH(2))
26850       XISR1 = XPSH(1,ISH(1))
26851       XISR2 = XPSH(2,ISH(2))
26852       IVO1  = IVAL(1)
26853       IVO2  = IVAL(2)
26854 C  valence flavours
26855       IF(IPB1.NE.0) THEN
26856         IF(ISH(1).GT.1) THEN
26857           CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26858           IF(IDPDG1.EQ.22) THEN
26859             CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26860             IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26861           ELSE
26862             CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26863             IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26864           ENDIF
26865         ENDIF
26866       ENDIF
26867       IF(IPB2.NE.0) THEN
26868         IF(ISH(2).GT.1) THEN
26869           CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26870           IF(IDPDG2.EQ.22) THEN
26871             CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26872             IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26873           ELSE
26874             IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26875           ENDIF
26876         ENDIF
26877       ENDIF
26878
26879 C  parton kinematics
26880       IF(NACC.GT.0) THEN
26881 C  final partons in CMS
26882         PM(3) = (XH1-XH2)*ECMP/2.D0
26883         PM(4) = (XH1+XH2)*ECMP/2.D0
26884         SH = XH1*XH2*ECMP**2
26885         SSH = SQRT(SH)
26886         GB(3) = PM(3)/SSH
26887         GB(4) = PM(4)/SSH
26888         CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26889      &    P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26890      &    PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26891         CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26892      &    P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26893      &    PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26894         IL(1) = 1
26895         IL(2) = 1
26896         DO 900 I=1,NACC
26897           IPA = IBRA(1,I)
26898           IPB = 3-IPA
26899           IL(IPA) = IBRA(2,I)
26900 C  new initial partons in CMS
26901           SH = SHAT(I)
26902           SSH = SQRT(SH)
26903           SHZ = SH/ZPSH(IPA,IL(IPA))
26904           SSHZ = SQRT(SHZ)
26905           Q2(1) = Q2SH(1,IL(1))
26906           Q2(2) = Q2SH(2,IL(2))
26907           PC(1,1) = 0.D0
26908           PC(1,2) = 0.D0
26909           PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26910      &             /(2.D0*SSH)
26911           PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26912           PC(2,1) = 0.D0
26913           PC(2,2) = 0.D0
26914           PC(2,3) = -PC(1,3)
26915           PC(2,4) = SSH-PC(1,4)
26916           XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26917           EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26918           S1 = SH+Q2(IPA)+Q2(IPB)
26919           S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26920           R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26921           R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26922           IF(Q2(IPB).LT.0.1D0) THEN
26923             XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26924      &             *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26925           ELSE
26926             XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26927      &             -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26928           ENDIF
26929           NGEN = 1
26930 C  max. virtuality for time-like showers
26931           QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26932           IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26933 C  generate time-like parton shower
26934             KF = IFL2(IPA,IL(IPA))
26935             IF(KF.EQ.0) KF = 21
26936             EER = MIN(EE3-PC(IPA,4),ECMP)
26937             THER = 0.
26938
26939             CALL PY1ENT(1,KF,EER,THER,THER)
26940             QMAXR = SQRT(QMAX)
26941             CALL PYSHOW(1,0,QMAXR)
26942 C debug output
26943             IF(IDEB(79).GE.25) THEN
26944               WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26945      &          'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26946      &          EER,QMAX,XMS4M,Q2(IPA)
26947               CALL PYLIST(1)
26948             ENDIF
26949             NGEN = PYK(0,1)
26950
26951             IF(NGEN.GT.1) THEN
26952               PJX = 0.D0
26953               PJY = 0.D0
26954               PJZ = 0.D0
26955               PJE = 0.D0
26956               KK = IPAL(IPA)
26957               DO 820 K=3,NGEN
26958
26959                 IF(PYK(K,1).LE.4) THEN
26960                   KK = KK+1
26961
26962                   IF(KK.GT.MXISR1) THEN
26963                     WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26964      &                'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26965                     IREJ = 1
26966                     RETURN
26967                   ENDIF
26968
26969                   PHISR(IPA,1,KK) = PYP(K,1)
26970                   PJX = PJX+PHISR(IPA,1,KK)
26971                   PHISR(IPA,2,KK) = PYP(K,2)
26972                   PJY = PJY+PHISR(IPA,2,KK)
26973                   PHISR(IPA,3,KK) = PYP(K,3)
26974                   PJZ = PJZ+PHISR(IPA,3,KK)
26975                   PHISR(IPA,4,KK) = PYP(K,4)
26976                   PJE = PJE+PHISR(IPA,4,KK)
26977                   IFLISR(IPA,KK)  = PYK(K,2)
26978
26979                   IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26980                   IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26981                   IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26982                 ENDIF
26983  820          CONTINUE
26984               NGEN = KK-IPAL(IPA)
26985               XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26986               PP4  = SQRT(PJE**2-XMS4)
26987               EE3  = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26988 C debug output
26989               IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26990      &         'PHO_HARISR: ',
26991      &         'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26992      &         PJE,PJX,PJY,PJZ,PP4,XMS4
26993             ENDIF
26994           ENDIF
26995           PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26996      &          /(2.D0*PC(IPA,3))
26997           PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26998           IF(PT3.LT.0.D0) THEN
26999             IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
27000      &        'PHO_HARISR: rejection due to PT3',PT3
27001             GOTO 10
27002           ENDIF
27003           PT3 = SQRT(PT3)
27004           CALL PHO_SFECFE(SFE,CFE)
27005           PX3 = CFE*PT3
27006           PY3 = SFE*PT3
27007 C
27008           IF(NGEN.GT.1) THEN
27009 C  time-like shower generated
27010             EE4 = EE3-PC(IPA,4)
27011             PZ4 = PZ3-PC(IPA,3)
27012             PP4 = SQRT(PT3**2+PZ4**2)
27013 C  Lorentz boost
27014             GAM = (EE4*PJE-PP4*PJZ)/XMS4
27015             BEG = (PJE*PP4-EE4*PJZ)/XMS4
27016 C  rotation angles
27017             CODD = PZ4/PP4
27018             SIDD = SQRT(PX3**2+PY3**2)/PP4
27019             COFD = 1.D0
27020             SIFD = 0.D0
27021             IF(PP4*SIDD.GT.1.D-5) THEN
27022               COFD = PX3/(SIDD*PP4)
27023               SIFD = PY3/(SIDD*PP4)
27024               ANORF = SQRT(COFD*COFD+SIFD*SIFD)
27025               COFD = COFD/ANORF
27026               SIFD = SIFD/ANORF
27027             ENDIF
27028 C  copy partons back
27029             KK = IPAL(IPA)
27030             DO 830 K=1,NGEN
27031               KK = KK+1
27032               PX = PHISR(IPA,1,KK)
27033               PY = PHISR(IPA,2,KK)
27034               PZ = PHISR(IPA,3,KK)
27035               COH= PHISR(IPA,4,KK)
27036               EE = GAM*COH+BEG*PZ
27037               PZ = GAM*PZ +BEG*COH
27038               PHISR(IPA,4,KK) = EE
27039               CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
27040      &          PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
27041  830        CONTINUE
27042             IPAL(IPA) = KK
27043           ELSE
27044 C  no time-like shower generated
27045             IPAL(IPA) = IPAL(IPA)+1
27046             PHISR(IPA,1,IPAL(IPA)) = PX3
27047             PHISR(IPA,2,IPAL(IPA)) = PY3
27048             PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
27049             PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
27050             IFLISR(IPA,IPAL(IPA))  = IFL2(IPA,IL(IPA))
27051           ENDIF
27052           PC(IPA,1) = PX3
27053           PC(IPA,2) = PY3
27054           PC(IPA,3) = PZ3
27055           PC(IPA,4) = EE3
27056 C  boost / rotate into new CMS
27057           DO 842 K=1,4
27058             GB(K) = (PC(1,K)+PC(2,K))/SSHZ
27059  842      CONTINUE
27060           CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
27061      &      PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
27062           COG= PM(3)/PTOT1
27063           SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
27064           COH=1.D0
27065           SIH=0.D0
27066           IF(PTOT1*SIG.GT.1.D-5) THEN
27067             COH=PM(1)/(SIG*PTOT1)
27068             SIH=PM(2)/(SIG*PTOT1)
27069             ANORF=SQRT(COH*COH+SIH*SIH)
27070             COH=COH/ANORF
27071             SIH=SIH/ANORF
27072           ENDIF
27073           DO 845 K=1,2
27074             DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
27075               CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
27076      &          PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
27077      &          PTOT1,PM(1),PM(2),PM(3),PM(4))
27078               CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
27079      &          PN(2),PN(3))
27080               CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
27081      &          PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
27082               PHISR(K,4,L) = PM(4)
27083  844        CONTINUE
27084  845      CONTINUE
27085  900    CONTINUE
27086 C  boost back to global CMS
27087         PM(3) = (XISR1-XISR2)/2.D0
27088         PM(4) = (XISR1+XISR2)/2.D0
27089         SSH = SQRT(XISR1*XISR2)
27090         GB(3) = PM(3)/SSH
27091         GB(4) = PM(4)/SSH
27092         DO 945 K=1,2
27093           DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
27094             CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
27095      &        PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
27096      &        PM(2),PM(3),PM(4))
27097             PHISR(K,1,L) = PM(1)
27098             PHISR(K,2,L) = PM(2)
27099             PHISR(K,3,L) = PM(3)
27100             PHISR(K,4,L) = PM(4)
27101  944      CONTINUE
27102  945    CONTINUE
27103       ENDIF
27104       IPOISR(1,2,IHIDX) = IPAL(1)
27105       IPOISR(2,2,IHIDX) = IPAL(2)
27106       IMXISR(1) = IPAL(1)
27107       IMXISR(2) = IPAL(2)
27108 C
27109 C  debug output
27110       IF(IDEB(79).GE.10) THEN
27111         WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
27112      &    ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
27113         IF(NACC.GT.0) THEN
27114           WRITE(LO,'(1X,A,2I5,/6X,A)')
27115      &    'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
27116      &    ' SIDE   NO.   IFLB IFLC     Q2SH    PT2SH     XH         ZZ'
27117           DO 600 II=1,NACC
27118             K = IBRA(1,II)
27119             I = IBRA(2,II)
27120             WRITE(LO,'(5X,4I5,4E11.3)')
27121      &        K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
27122      &        ZPSH(K,I)
27123  600      CONTINUE
27124         ENDIF
27125 C  check of final configuration
27126         PX3 = 0.D0
27127         PY3 = 0.D0
27128         PZ3 = 0.D0
27129         EE3 = 0.D0
27130         IFSUM(1) = 0
27131         IFSUM(2) = 0
27132         WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
27133         DO 745 K=1,2
27134           DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
27135             WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
27136      &        PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
27137             IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
27138             PX3 = PX3 + PHISR(K,1,L)
27139             PY3 = PY3 + PHISR(K,2,L)
27140             PZ3 = PZ3 + PHISR(K,3,L)
27141             EE3 = EE3 + PHISR(K,4,L)
27142  744      CONTINUE
27143  745    CONTINUE
27144         IFSUM(1) = IFSUM(1)-IPB1
27145         IFSUM(2) = IFSUM(2)-IPB2
27146         PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
27147         EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
27148         WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
27149      &    IFSUM,PX3,PY3,PZ3,EE3
27150       ENDIF
27151       END
27152
27153 *$ CREATE PHO_HARZSP.FOR
27154 *COPY PHO_HARZSP
27155 CDECK  ID>, PHO_HARZSP
27156       SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
27157 C*********************************************************************
27158 C
27159 C     sampling of z values from DGLAP kernels
27160 C
27161 C     input:  IFLA,IFLB      parton flavours
27162 C             NFSH           flavours involved in hard processes
27163 C             ZMIN           minimal ZZ allowed
27164 C             ZMAX           maximal ZZ allowed
27165 C
27166 C     output: ZZ             z value
27167 C
27168 C*********************************************************************
27169       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27170       SAVE
27171
27172       PARAMETER ( DEPS   =  1.D-10 )
27173
27174 C  input/output channels
27175       INTEGER LI,LO
27176       COMMON /POINOU/ LI,LO
27177 C  event debugging information
27178       INTEGER NMAXD
27179       PARAMETER (NMAXD=100)
27180       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27181      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27182       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27183      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27184 C  internal rejection counters
27185       INTEGER NMXJ
27186       PARAMETER (NMXJ=60)
27187       CHARACTER*10 REJTIT
27188       INTEGER IFAIL
27189       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27190
27191       IF(ZMAX.LE.ZMIN) THEN
27192         WRITE(LO,'(1X,A,2E12.3)')
27193      &    'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
27194         CALL PHO_PREVNT(-1)
27195         ZZ = 0.D0
27196         RETURN
27197       ENDIF
27198 C
27199       IF(IFLB.EQ.0) THEN
27200         IF(IFLA.EQ.0) THEN
27201 C  g --> g g
27202           C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
27203           C2 = (1.D0-ZMIN)/ZMIN
27204  100      CONTINUE
27205             ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
27206           IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
27207         ELSE IF(ABS(IFLA).LE.NFSH) THEN
27208 C  q --> q g
27209           C1 = ZMAX/ZMIN
27210  200      CONTINUE
27211             ZZ = ZMIN*C1**DT_RNDM(ZMIN)
27212           IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
27213         ELSE
27214           GOTO 900
27215         ENDIF
27216       ELSE IF(ABS(IFLB).LE.NFSH) THEN
27217         IF(IFLA.EQ.0) THEN
27218 C  g --> q qb
27219           C1 = ZMAX-ZMIN
27220  300      CONTINUE
27221             ZZ = ZMIN+C1*DT_RNDM(ZMIN)
27222           IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
27223         ELSE IF(ABS(IFLA).LE.NFSH) THEN
27224 C  q --> g q
27225           C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
27226           C2 = 1.D0-ZMIN
27227  400      CONTINUE
27228             ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
27229           IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
27230         ELSE
27231           GOTO 900
27232         ENDIF
27233       ELSE
27234         GOTO 900
27235       ENDIF
27236 C  debug output
27237       IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
27238      &  'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
27239      &  IFLA,IFLB,ZZ,ZMIN,ZMAX
27240       RETURN
27241
27242  900  CONTINUE
27243       WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
27244      &  IFLA,IFLB
27245       CALL PHO_ABORT
27246
27247       END
27248
27249 *$ CREATE PHO_ALPHAE.FOR
27250 *COPY PHO_ALPHAE
27251 CDECK  ID>, PHO_ALPHAE
27252       DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
27253 C**********************************************************************
27254 C
27255 C     calculation of ALPHA_em
27256 C
27257 C     input:    Q2      scale in GeV**2
27258 C
27259 C**********************************************************************
27260
27261       IMPLICIT NONE
27262
27263       SAVE
27264
27265       DOUBLE PRECISION Q2
27266
27267 C  input/output channels
27268       INTEGER LI,LO
27269       COMMON /POINOU/ LI,LO
27270 C  model switches and parameters
27271       CHARACTER*8 MDLNA
27272       INTEGER ISWMDL,IPAMDL
27273       DOUBLE PRECISION PARMDL
27274       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27275
27276       DOUBLE PRECISION PYALEM
27277
27278       pho_alphae = 1.D0/137.D0
27279
27280       if(ipamdl(120).eq.1) then
27281
27282         pho_alphae = PYALEM(Q2)
27283
27284       endif
27285
27286       END
27287
27288 *$ CREATE PHO_ALPHAS.FOR
27289 *COPY PHO_ALPHAS
27290 CDECK  ID>, PHO_ALPHAS
27291       DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27292 C**********************************************************************
27293 C
27294 C     calculation of ALPHA_S
27295 C
27296 C     input:    IMODE = 1         lambda_QCD**2 for PDF 1 evolution
27297 C                       2         lambda_QCD**2 for PDF 2 evolution
27298 C                       3         lambda_QCD**2 for hard scattering
27299 C               Q2      scale in GeV**2
27300 C
27301 C     initialization needed:
27302 C               IMODE = 0         lambda values taken from PDF table
27303 C                       -1        given Q2 is 4-flavour lambda 1
27304 C                       -2        given Q2 is 4-flavour lambda 2
27305 C                       -3        given Q2 is 4-flavour lambda 3
27306 C
27307 C
27308 C**********************************************************************
27309
27310       IMPLICIT NONE
27311
27312       SAVE
27313
27314       DOUBLE PRECISION Q2
27315       INTEGER IMODE
27316
27317 C  input/output channels
27318       INTEGER LI,LO
27319       COMMON /POINOU/ LI,LO
27320 C  model switches and parameters
27321       CHARACTER*8 MDLNA
27322       INTEGER ISWMDL,IPAMDL
27323       DOUBLE PRECISION PARMDL
27324       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27325 C  hard scattering parameters used for most recent hard interaction
27326       INTEGER NFbeta,NF
27327       DOUBLE PRECISION ALQCD2,BQCD
27328       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27329 C  currently activated parton density parametrizations
27330       CHARACTER*8 PDFNAM
27331       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27332       DOUBLE PRECISION PDFLAM,PDFQ2M
27333       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27334      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27335
27336       INTEGER I
27337
27338       PHO_ALPHAS = 0.D0
27339
27340       IF(IMODE.GT.0) THEN
27341
27342         IF(Q2.LT.PARMDL(148)) THEN
27343           NFbeta = 1
27344         ELSE IF(Q2.LT.PARMDL(149)) THEN
27345           NFbeta = 2
27346         ELSE IF(Q2.LT.PARMDL(150)) THEN
27347           NFbeta = 3
27348         ELSE
27349           NFbeta = 4
27350         ENDIF
27351
27352         PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27353         NFbeta = NFbeta+2
27354
27355       ELSE IF(IMODE.EQ.0) THEN
27356
27357         DO I=1,3
27358           if(I.EQ.3) then
27359             ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27360           else
27361             ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27362           endif
27363           ALQCD2(I,1) = PARMDL(148)
27364      &                 *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27365           ALQCD2(I,3) = PARMDL(149)
27366      &                 *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27367           ALQCD2(I,4) = PARMDL(150)
27368      &                 *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27369
27370         ENDDO
27371
27372       ELSE IF(IMODE.LT.0) THEN
27373
27374         if(IMODE.eq.-4) then
27375           I = 3
27376           ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27377         else
27378           I = -IMODE
27379           ALQCD2(I,2) = Q2
27380         endif
27381         ALQCD2(I,1) = PARMDL(148)
27382      &               *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27383         ALQCD2(I,3) = PARMDL(149)
27384      &               *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27385         ALQCD2(I,4) = PARMDL(150)
27386      &               *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27387
27388       ENDIF
27389
27390       END
27391
27392 *$ CREATE PHO_DFWRAP.FOR
27393 *COPY PHO_DFWRAP
27394 CDECK  ID>, PHO_DFWRAP
27395       SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27396 C**********************************************************************
27397 C
27398 C     wrapper for diffraction dissociation in hadron-nucleus and
27399 C     nucleus-nucleus collisions with DPMJET
27400 C
27401 C     input:      MODE     1:   transformation into CMS
27402 C                          2:   transformation into Lab
27403 C                 JM1/2    indices of old mother particles
27404 C                 JM1/2N   indices of new mother particles
27405 C
27406 C**********************************************************************
27407
27408       IMPLICIT NONE
27409
27410       SAVE
27411
27412       INTEGER MODE,JM1,JM2
27413
27414 C  input/output channels
27415       INTEGER LI,LO
27416       COMMON /POINOU/ LI,LO
27417 C  event debugging information
27418       INTEGER NMAXD
27419       PARAMETER (NMAXD=100)
27420       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27421      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27422       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27423      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27424
27425 C  standard particle data interface
27426       INTEGER NMXHEP
27427
27428       PARAMETER (NMXHEP=4000)
27429
27430       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27431       DOUBLE PRECISION PHEP,VHEP
27432       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27433      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27434      &                VHEP(4,NMXHEP)
27435 C  extension to standard particle data interface (PHOJET specific)
27436       INTEGER IMPART,IPHIST,ICOLOR
27437       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27438
27439 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
27440       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27441       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27442       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27443      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27444
27445       DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27446       DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27447
27448       INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27449
27450 C  transformation into CMS
27451
27452       IF(MODE.EQ.1) THEN
27453
27454         JM1S = JM1
27455         JM2S = JM2
27456         NHEPS = NHEP
27457
27458         XM1 = PHEP(5,JM1)
27459         XM2 = PHEP(5,JM2)
27460
27461 C  boost into CMS
27462         P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27463         P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27464         P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27465         P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27466         SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27467         ECMD = SQRT(SS)
27468         DO 10 I=1,4
27469           GAMBED(I) = P1(I)/ECMD
27470  10     CONTINUE
27471         CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27472      &             PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27473      &             PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27474 C  rotation angles
27475         CODD = P1(3)/PTOT1
27476         SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27477         COFD = 1.D0
27478         SIFD = 0.D0
27479         IF(PTOT1*SIDD.GT.1.D-5) THEN
27480           COFD = P1(1)/(SIDD*PTOT1)
27481           SIFD = P1(2)/(SIDD*PTOT1)
27482           ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27483           COFD = COFD/ANORF
27484           SIFD = SIFD/ANORF
27485         ENDIF
27486
27487 C  initial particles in CMS
27488
27489         P1(1) = 0.D0
27490         P1(2) = 0.D0
27491         P1(3) = ECMD/2.D0*XPSUB
27492         P1(4) = P1(3)
27493
27494         P2(1) = 0.D0
27495         P2(2) = 0.D0
27496         P2(3) = -ECMD/2.D0*XTSUB
27497         P2(4) = -P2(3)
27498
27499         CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27500
27501         CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27502      &    P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27503      &    ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27504
27505         CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27506      &    P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27507      &    ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27508
27509         JM1 = JM1N
27510         JM2 = JM2N
27511
27512 C  transformation into lab.
27513
27514       ELSE IF(MODE.EQ.2) THEN
27515
27516         CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27517      &    GAMBED(1),GAMBED(2),GAMBED(3))
27518
27519         JM1 = JM1S
27520         JM2 = JM2S
27521
27522 C  clean up after rejection
27523
27524       ELSE IF(MODE.EQ.-2) THEN
27525
27526         NHEP = NHEPS
27527
27528         JM1 = JM1S
27529         JM2 = JM2S
27530
27531       ELSE
27532
27533         WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27534
27535       ENDIF
27536
27537       END
27538
27539 *$ CREATE PHO_DIFDIS.FOR
27540 *COPY PHO_DIFDIS
27541 CDECK  ID>, PHO_DIFDIS
27542       SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27543      &                      MSOFT,MHARD,IREJ)
27544 C***********************************************************************
27545 C
27546 C     sampling of diffractive events of different kinds,
27547 C                            (produced particles stored in /POEVT1/)
27548 C
27549 C     input:   IDIF1/2   diffractive process particle 1/2
27550 C                          0   elastic/quasi-elastic scattering
27551 C                          1   diffraction dissociation
27552 C              IMOTH1/2  index of mother particles in /POEVT1/
27553 C              SPROB     suppression factor (survival probability) for
27554 C                        resolved diffraction dissociation
27555 C              IMODE     mode of operation
27556 C                          0  sampling of diffractive cut
27557 C                          1  sampling of enhanced cut
27558 C                          2  sampling of diffractive cut without
27559 C                             scattering (needed for double-pomeron)
27560 C                         -1  initialization
27561 C                         -2  output of statistics
27562 C
27563 C     output:   MSOFT    number of generated soft strings
27564 C               MHARD    number of generated hard strings
27565 C               IDIF1/2  diffraction label for particle 1/2 in /PROCES/
27566 C                          0   quasi elastic scattering
27567 C                          1   low-mass diffractive dissociation
27568 C                          2   soft high-mass diffractive dissociation
27569 C                          3   hard resolved diffractive dissociation
27570 C                          4   hard direct diffractive dissociation
27571 C               IREJ     rejection label
27572 C                          0  successful generation of partons
27573 C                          1  failure
27574 C
27575 C***********************************************************************
27576       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27577       SAVE
27578
27579       PARAMETER ( EPS  = 1.D-7,
27580      &            DEPS = 1.D-10)
27581
27582 C  input/output channels
27583       INTEGER LI,LO
27584       COMMON /POINOU/ LI,LO
27585 C  event debugging information
27586       INTEGER NMAXD
27587       PARAMETER (NMAXD=100)
27588       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27589      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27590       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27591      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27592 C  general process information
27593       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27594       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27595 C  internal rejection counters
27596       INTEGER NMXJ
27597       PARAMETER (NMXJ=60)
27598       CHARACTER*10 REJTIT
27599       INTEGER IFAIL
27600       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27601 C  global event kinematics and particle IDs
27602       INTEGER IFPAP,IFPAB
27603       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27604       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27605 C  c.m. kinematics of diffraction
27606       INTEGER NPOSD
27607       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27608      &                 SIDD,CODD,SIFD,COFD,PDCMS
27609       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27610      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27611 C  obsolete cut-off information
27612       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27613       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27614 C  some constants
27615       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27616       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27617      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27618 C  model switches and parameters
27619       CHARACTER*8 MDLNA
27620       INTEGER ISWMDL,IPAMDL
27621       DOUBLE PRECISION PARMDL
27622       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27623 C  Reggeon phenomenology parameters
27624       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27625      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27626       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27627      &                ALREG,ALREGP,GR(2),B0REG(2),
27628      &                GPPP,GPPR,B0PPP,B0PPR,
27629      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27630 C  parameters of 2x2 channel model
27631       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27632       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27633 C  table of particle indices for recursive PHOJET calls
27634       INTEGER MAXIPX
27635       PARAMETER ( MAXIPX = 100 )
27636       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27637       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27638      &                IPOIX1,IPOIX2,IPOIX3
27639
27640 C  standard particle data interface
27641       INTEGER NMXHEP
27642
27643       PARAMETER (NMXHEP=4000)
27644
27645       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27646       DOUBLE PRECISION PHEP,VHEP
27647       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27648      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27649      &                VHEP(4,NMXHEP)
27650 C  extension to standard particle data interface (PHOJET specific)
27651       INTEGER IMPART,IPHIST,ICOLOR
27652       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27653
27654 C  event weights and generated cross section
27655       INTEGER IPOWGC,ISWCUT,IVWGHT
27656       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27657       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27658      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27659
27660       DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27661       DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27662       DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27663      &          IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27664      &          IDIR(2),IPROC(2)
27665
27666       IF(IMODE.EQ.-1) THEN
27667 C  initialization
27668         RETURN
27669       ELSE IF(IMODE.EQ.-2) THEN
27670 C  output of statistics
27671         RETURN
27672       ENDIF
27673
27674       IREJ = 0
27675 C  mass cuts
27676       PIMASS  = 0.140D0
27677 C  debug output
27678       IF(IDEB(45).GE.10) THEN
27679         WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27680      &    'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27681      &    IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27682       ENDIF
27683       IPAR(1) = IDIF1
27684       IPAR(2) = IDIF2
27685 C  save current status
27686       MSOFT = 0
27687       MHARD = 0
27688       KHPOMS = KHPOM
27689       KSPOMS = KSPOM
27690       KSREGS = KSREG
27691       KHDIRS = KHDIR
27692       IPOIS1 = IPOIX1
27693       IPOIS2 = IPOIX2
27694       IPOIS3 = IPOIX3
27695       JDA11 = JDAHEP(1,IMOTH1)
27696       JDA21 = JDAHEP(2,IMOTH1)
27697       JDA12 = JDAHEP(1,IMOTH2)
27698       JDA22 = JDAHEP(2,IMOTH2)
27699       ISTH1 = ISTHEP(IMOTH1)
27700       ISTH2 = ISTHEP(IMOTH2)
27701       NHEPS = NHEP
27702 C  get mother data
27703       NPOSD(1) = IMOTH1
27704       NPOSD(2) = IMOTH2
27705       DO 20 I=1,2
27706         IDPDG(I) = IDHEP(NPOSD(I))
27707         IDBAM(I) = IMPART(NPOSD(I))
27708         AMP(I) = PHO_PMASS(IDBAM(I),0)
27709         IF(IDPDG(I).EQ.22) THEN
27710           PMASSD(I) = 0.765D0
27711           PVIRTD(I) = PHEP(5,NPOSD(I))**2
27712         ELSE
27713           PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27714           PVIRTD(I) = 0.D0
27715         ENDIF
27716  20   CONTINUE
27717 C  get CM system
27718       P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27719       P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27720       P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27721       P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27722       SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27723       ECMD = SQRT(SS)
27724       IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27725      &  'PHO_DIFDIS: availabe energy',ECMD
27726 C  check total available energy
27727       IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27728         IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27729      &    'PHO_DIFDIS: ',
27730      &    'not enough energy for inelastic diffraction',
27731      &    'ECM, particle masses:',ECMD,AMP
27732         IFAIL(7) = IFAIL(7)+1
27733         IREJ = 1
27734         RETURN
27735       ENDIF
27736 C  boost into CMS
27737       DO 10 I=1,4
27738         GAMBED(I) = P1(I)/ECMD
27739  10   CONTINUE
27740       CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27741      &           PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27742      &           PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27743 C  rotation angles
27744       CODD = P1(3)/PTOT1
27745       SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27746       COFD = 1.D0
27747       SIFD = 0.D0
27748       IF(PTOT1*SIDD.GT.1.D-5) THEN
27749         COFD = P1(1)/(SIDD*PTOT1)
27750         SIFD = P1(2)/(SIDD*PTOT1)
27751         ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27752         COFD = COFD/ANORF
27753         SIFD = SIFD/ANORF
27754       ENDIF
27755 C  initial particles in CMS
27756       PDCMS(1,1) = 0.D0
27757       PDCMS(2,1) = 0.D0
27758       PDCMS(3,1) = PTOT1
27759       PDCMS(4,1) = P1(4)
27760       PDCMS(1,2) = 0.D0
27761       PDCMS(2,2) = 0.D0
27762       PDCMS(3,2) = -PTOT1
27763       PDCMS(4,2) = ECMD-P1(4)
27764 C  get new CM momentum
27765       AM12 = PMASSD(1)**2
27766       AM22 = PMASSD(2)**2
27767       PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27768
27769 C  coherence constraint (min/max diffractive mass allowed)
27770       IF(IMODE.EQ.2) THEN
27771         THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27772         THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27773         THRM2 = SQRT(1-PARMDL(72))*ECMD
27774         THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27775       ELSE
27776         THRM1 = PARMDL(46)
27777         THRM2 = PARMDL(45)*ECMD
27778 C  check kinematic limits
27779         IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27780         IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27781       ENDIF
27782
27783 C  check energy vs. coherence constraints
27784       IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27785       IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27786
27787 C  no phase space available
27788       IF(IPAR(1)+IPAR(2).EQ.0) THEN
27789         IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27790      &    'PHO_DIFDIS: ',
27791      &    'not enough phase space for ine. diffraction (Ecm)',ECMD,
27792      &    'side 1: min. mass, upper mass limit:',
27793      &    MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27794      &    'side 2: min. mass, upper mass limit:',
27795      &    MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27796         IFAIL(7) = IFAIL(7)+1
27797         IREJ = 1
27798         RETURN
27799       ENDIF
27800
27801       ITRY = 0
27802       ITRYM = 10
27803       IPARS1 = IPAR(1)
27804       IPARS2 = IPAR(2)
27805
27806 C  main rejection loop
27807 C -------------------------------
27808  50   CONTINUE
27809       ITRY = ITRY+1
27810       IF(ITRY.GT.1) THEN
27811         IFAIL(13) = IFAIL(13)+1
27812         IF(ITRY.GE.ITRYM) THEN
27813           IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27814      &      'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27815           IFAIL(7) = IFAIL(7)+1
27816           IREJ = 1
27817           RETURN
27818         ENDIF
27819       ENDIF
27820       KSPOM = KSPOMS
27821       KHPOM = KHPOMS
27822       KHDIR = KHDIRS
27823       KSREG = KSREGS
27824       IPAR(1) = IPARS1
27825       IPAR(2) = IPARS2
27826 C  reset mother-daugther relations
27827       NHEP = NHEPS
27828       JDAHEP(1,IMOTH1) = JDA11
27829       JDAHEP(2,IMOTH1) = JDA21
27830       JDAHEP(1,IMOTH2) = JDA12
27831       JDAHEP(2,IMOTH2) = JDA22
27832       ISTHEP(IMOTH1) = ISTH1
27833       ISTHEP(IMOTH2) = ISTH2
27834       IPOIX1 = IPOIS1
27835       IPOIX2 = IPOIS2
27836       IPOIX3 = IPOIS3
27837 C
27838       NSLP = 0
27839       NCOR = 0
27840  55   CONTINUE
27841
27842 C  calculation of kinematics
27843       DO 100 I=1,2
27844 C  sampling of masses
27845         IRPDG(I) = 0
27846         IRBAM(I) = 0
27847         IFL1P(I) = IDPDG(I)
27848         IFL2P(I) = IDBAM(I)
27849         IVEC(I)  = 0
27850         IDIR(I) = 0
27851         ISAM(I) = 0
27852         JSAM(I) = 0
27853         KSAM(I) = 0
27854         IF(IPAR(I).EQ.0) THEN
27855 C  vector meson dominance assumed
27856           XMASS(I) = AMP(I)
27857           CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27858 C  diffraction dissociation
27859         ELSE IF(IPAR(I).EQ.1) THEN
27860           XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27861           PREF2 = PMASSD(I)**2
27862           XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27863         ELSE
27864           WRITE(LO,'(/1X,A,2I3)')
27865      &      'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27866           CALL PHO_ABORT
27867         ENDIF
27868  100  CONTINUE
27869
27870 C  sampling of momentum transfer
27871       CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27872      &            THRM2,TT,SLWGHT,IREJ)
27873       IF(IREJ.NE.0) THEN
27874         NSLP=NSLP+1
27875         IF(NSLP.LT.100) GOTO 55
27876         WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27877      &   'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27878         IREJ = 5
27879         RETURN
27880       ENDIF
27881
27882 C  correct for t-M^2 correlation in diffraction
27883       IF(DT_RNDM(TT).GT.SLWGHT) THEN
27884         NCOR=NCOR+1
27885         IF(NCOR.LT.100) GOTO 55
27886         WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27887      &   'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27888         IREJ = 5
27889         RETURN
27890       ENDIF
27891
27892 C  debug output
27893       IF(IDEB(45).GE.5) THEN
27894         WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27895      &    'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27896       ENDIF
27897 C  not double pomeron scattering
27898       IF(IMODE.NE.2) THEN
27899 C  sample diffractive interaction processes
27900         DO 120 I=1,2
27901           IF(IPAR(I).NE.0) THEN
27902 C  find particle combination
27903             IF(IDPDG(I).EQ.IFPAP(1)) THEN
27904               IP = 2
27905             ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27906               IP = 3
27907             ELSE IF(IDPDG(I).EQ.990) THEN
27908               IP = 4
27909             ELSE
27910               IP = I+1
27911             ENDIF
27912 C  sample dissociation process
27913             CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27914      &        PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27915      &        KSAM(I),IDIR(I))
27916             IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27917 C  store process label
27918               IF(IDIR(I).GT.0) THEN
27919                 IPAR(I) = 4
27920               ELSE IF(KSAM(I).GT.0) THEN
27921                 IPAR(I) = 3
27922               ELSE IF(ISAM(I).GT.0) THEN
27923                 IPAR(I) = 2
27924               ELSE
27925                 IPAR(I) = 1
27926 C  mass fine correction
27927                 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27928      &            XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27929                 XMASS(I) = XMNEW
27930               ENDIF
27931             ELSE
27932 C  diffractive pomeron-hadron interaction
27933               IPAR(I) = 10+IPROC(I)
27934             ENDIF
27935 C  debug output
27936             IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27937      &        'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27938      &        IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27939           ENDIF
27940  120    CONTINUE
27941       ENDIF
27942 C  actualize debug information
27943       IF(IMODE.EQ.1) THEN
27944         IDIFR1 = IPAR(1)
27945         IDIFR2 = IPAR(2)
27946       ENDIF
27947 C  calculate new momenta in CMS
27948       CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27949       IF(IREJ.NE.0) GOTO 50
27950       DO 130 I=1,4
27951         PP(I,1) = P1(I)
27952         PP(I,2) = P2(I)
27953  130  CONTINUE
27954
27955 C  comment line for diffraction
27956       CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27957      &   XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27958 C  write diffractive strings/particles
27959       DO 200 I=1,2
27960         I1 = I
27961         I2 = 3-I1
27962         DO K=1,4
27963           PD1(K) = PP(K,I1)
27964           PD2(K) = PP(K,I2)
27965         ENDDO
27966         PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27967         PP(7,I1) = TT
27968         IGEN = IPHIST(2,NPOSD(I1))
27969         if(IGEN.eq.0) IGEN = -I1*10
27970         CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27971      &    IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27972         IF(IREJ.NE.0) THEN
27973           IFAIL(7+I) = IFAIL(7+I)+1
27974           IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27975      &      'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27976      &      I,IPAR(I),XMASS(I)
27977           GOTO 50
27978         ENDIF
27979         ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27980  200  CONTINUE
27981 C  double-pomeron scattering?
27982       IF(IMODE.EQ.2) GOTO 150
27983
27984 C  diffractive final states
27985       DO 300 I=1,2
27986  110    CONTINUE
27987         IF(IPAR(I).EQ.0) THEN
27988 C  vector meson production
27989           IF(IDPDG(I).EQ.22) THEN
27990             IF(ISWMDL(21).GE.0) THEN
27991               ISP = IPAMDL(3)
27992               IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27993               CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27994             ENDIF
27995 C  hadronic state of multi-pomeron coupling
27996           ELSE IF(IDPDG(I).EQ.990) THEN
27997             CALL PHO_SDECAY(IPOSP(1,I),0,2)
27998           ENDIF
27999         ELSE
28000           IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
28001             IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
28002             IF(IDIR(I).GT.0) THEN
28003               IPAR(I) = 4
28004             ELSE IF(KSAM(I).GT.0) THEN
28005               IPAR(I) = 3
28006             ELSE IF(ISAM(I).GT.0) THEN
28007               IPAR(I) = 2
28008             ELSE
28009               IPAR(I) = 1
28010             ENDIF
28011           ELSE
28012             IPAR(I) = 10+IPROC(I)
28013           ENDIF
28014           IPHIST(I,ICPOS) = IPAR(I)
28015 C  update debug informantion
28016           KSPOM = ISAM(I)
28017           KSREG = JSAM(I)
28018           KHPOM = KSAM(I)
28019           KHDIR = IDIR(I)
28020           IDIFR1 = IPAR(1)
28021           IDIFR2 = IPAR(2)
28022           IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
28023
28024 C  resonance decay, pi+pi- background
28025             P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
28026             P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
28027             P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
28028             P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
28029             CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
28030      &        P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
28031 C  decay
28032             IF(IDPDG(I).EQ.22) THEN
28033               IPHIST(2,IPOS) = 3
28034               IF(ISWMDL(21).GE.0) THEN
28035                 ISP = IPAMDL(3)
28036                 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
28037                 CALL PHO_SDECAY(IPOS,ISP,2)
28038               ENDIF
28039             ELSE
28040               CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
28041             ENDIF
28042             IREJ = 0
28043           ELSE
28044
28045 C  particle-pomeron scattering
28046             IF(IPAR(I).LE.4) THEN
28047 C  non-diffractive particle-pomeron scattering
28048               IGEN = IPHIST(2,NPOSD(I))
28049               if(IGEN.eq.0) then
28050                 if(I.eq.1) then
28051                   IGEN = 5
28052                 else
28053                   IGEN = 6
28054                 endif
28055               endif
28056               CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
28057      &          ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
28058             ELSE
28059 C  diffractive particle-pomeron scattering
28060               IPOIX2 = IPOIX2+1
28061               IPORES(IPOIX2)   = IPROC(I)
28062               IPOPOS(1,IPOIX2) = IPOSP(1,I)
28063               IPOPOS(2,IPOIX2) = IPOSP(2,I)
28064             ENDIF
28065           ENDIF
28066         ENDIF
28067
28068 C  rejection?
28069         IF(IREJ.NE.0) THEN
28070           IFAIL(20+I) = IFAIL(20+I)+1
28071           IF(IPAR(I).GT.1) THEN
28072             IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
28073             IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
28074             IF(IDIR(I).GT.0) THEN
28075               IDIR(I) = 0
28076             ELSE IF(KSAM(I).GT.0) THEN
28077               KSAM(I) = KSAM(I)-1
28078             ELSE IF(ISAM(I).GT.0) THEN
28079               ISAM(I) = ISAM(I)-1
28080             ENDIF
28081             GOTO 110
28082           ELSE
28083             IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28084      &        'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
28085      &        I,IPAR(I),XMASS(I)
28086             GOTO 50
28087           ENDIF
28088         ENDIF
28089  300  CONTINUE
28090
28091       IDIF1 = IPAR(1)
28092       IDIF2 = IPAR(2)
28093 C  update debug information
28094       KSPOM = KSPOMS+ISAM(1)+ISAM(2)
28095       KSREG = KSREGS+JSAM(1)+JSAM(2)
28096       KHPOM = KHPOMS+KSAM(1)+KSAM(2)
28097       KHDIR = KHDIRS+IDIR(1)+IDIR(2)
28098
28099  150  CONTINUE
28100
28101 C  debug output
28102       IF(IDEB(45).GE.10) THEN
28103         WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
28104      &    'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
28105      &    IPAR,NPOSD,MSOFT,MHARD,IMODE
28106       ENDIF
28107       IF(IDEB(45).GE.15) THEN
28108         WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
28109      &                        '------------------------------'
28110         CALL PHO_PREVNT(0)
28111       ENDIF
28112
28113       END
28114
28115 *$ CREATE PHO_DIFPRO.FOR
28116 *COPY PHO_DIFPRO
28117 CDECK  ID>, PHO_DIFPRO
28118       SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
28119      &                  IPROC,ISAM,JSAM,KSAM,IDIR)
28120 C*********************************************************************
28121 C
28122 C     sampling of diffraction dissociation process
28123 C
28124 C     input:  IP       particle combination
28125 C             ICUT     user imposed limitations
28126 C             ID1/2    PDG particle code of scattering particles
28127 C             XMASS    diffractively produced mass (GeV)
28128 C             P2V1/2   virtuality of scattering particles (Gev**2)
28129 C             SPROB    suppression factor for resolved single and
28130 C                      double diffraction dissociation
28131 C
28132 C     output: IRPOC    process ID
28133 C             ISAM     number of cut pomerons (soft)
28134 C             JSAM     number of cut reggeons
28135 C             KSAM     number of cut pomerons (hard)
28136 C             IDIR     direct hard interaction
28137 C
28138 C*********************************************************************
28139       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28140       SAVE
28141
28142 C  input/output channels
28143       INTEGER LI,LO
28144       COMMON /POINOU/ LI,LO
28145 C  event debugging information
28146       INTEGER NMAXD
28147       PARAMETER (NMAXD=100)
28148       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28149      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28150       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28151      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28152 C  general process information
28153       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28154       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28155 C  model switches and parameters
28156       CHARACTER*8 MDLNA
28157       INTEGER ISWMDL,IPAMDL
28158       DOUBLE PRECISION PARMDL
28159       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28160 C  energy-interpolation table
28161       INTEGER IEETA2
28162       PARAMETER ( IEETA2 = 20 )
28163       INTEGER ISIMAX
28164       DOUBLE PRECISION SIGTAB,SIGECM
28165       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28166
28167       ISAM = 0
28168       JSAM = 0
28169       KSAM = 0
28170       IDIR = 0
28171
28172       IF(XMASS.GT.3.D0) THEN
28173 C  rapidity gap survival probability
28174         SPRO = 1.D0
28175         IF(ISWMDL(28).GE.1) SPRO = SPROB
28176 C  sample interaction
28177         IPROC = 0
28178         CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
28179       ELSE
28180         IPROC = 1
28181       ENDIF
28182       IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
28183 C  non-diffractive hadron-pomeron interaction
28184       IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28185 C  option for suppression of multiple interaction
28186         IF(ICUT.EQ.0) THEN
28187           IPROC = 1
28188           IF(ISAM+KSAM+IDIR.GT.0) THEN
28189             ISAM = 1
28190             JSAM = 0
28191           ELSE
28192             JSAM = 1
28193           ENDIF
28194           KSAM = 0
28195           IDIR = 0
28196         ELSE IF(ICUT.EQ.1) THEN
28197           IF(IDIR.GT.0) THEN
28198           ELSE IF(KSAM.GT.0) THEN
28199             KSAM = 1
28200             ISAM = 0
28201             JSAM = 0
28202           ELSE IF(ISAM.GT.0) THEN
28203             ISAM = 1
28204             JSAM = 0
28205           ELSE
28206             JSAM = 1
28207           ENDIF
28208         ELSE IF(ICUT.EQ.2) THEN
28209           KSAM = MIN(KSAM,1)
28210         ELSE IF(ICUT.EQ.3) THEN
28211           ISAM = MIN(ISAM,1)
28212         ENDIF
28213       ENDIF
28214       END
28215
28216 *$ CREATE PHO_DIFPAR.FOR
28217 *COPY PHO_DIFPAR
28218 CDECK  ID>, PHO_DIFPAR
28219       SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
28220      &                     IPOSH1,IPOSH2,IMODE,IREJ)
28221 C***********************************************************************
28222 C
28223 C     perform string construction for diffraction dissociation
28224 C
28225 C     input:     IMOTH1,2     index of mother particles in POEVT1
28226 C                IGENM        production process of mother particles
28227 C                IFL1,IFL2    particle numbers
28228 C                             (IDPDG,IDBAM for quasi-elas. hadron)
28229 C                IPAR         0  quasi-elasic scattering
28230 C                             1  single string configuration
28231 C                             2  two string configuration
28232 C                P1           massive 4 momentum of first
28233 C                P1(6)        virtuality/squ.mass of particle (GeV**2)
28234 C                P1(7)        virtuality of Pomeron (neg, GeV**2)
28235 C                P2           massive 4 momentum of second particle
28236 C                IMODE        1   diffraction dissociation
28237 C                             2   double-pomeron scattering
28238 C
28239 C     output:    IPOSH1,2     index of the particles in /POEVT1/
28240 C                IREJ         0  successful string construction
28241 C                             1  no string construction possible
28242 C
28243 C***********************************************************************
28244       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28245       SAVE
28246
28247       DIMENSION P1(7),P2(7)
28248
28249       PARAMETER ( EPS  = 1.D-7,
28250      &            DEPS = 1.D-10)
28251
28252 C  input/output channels
28253       INTEGER LI,LO
28254       COMMON /POINOU/ LI,LO
28255 C  event debugging information
28256       INTEGER NMAXD
28257       PARAMETER (NMAXD=100)
28258       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28259      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28260       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28261      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28262 C  internal rejection counters
28263       INTEGER NMXJ
28264       PARAMETER (NMXJ=60)
28265       CHARACTER*10 REJTIT
28266       INTEGER IFAIL
28267       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28268 C  c.m. kinematics of diffraction
28269       INTEGER NPOSD
28270       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28271      &                 SIDD,CODD,SIFD,COFD,PDCMS
28272       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28273      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28274 C  model switches and parameters
28275       CHARACTER*8 MDLNA
28276       INTEGER ISWMDL,IPAMDL
28277       DOUBLE PRECISION PARMDL
28278       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28279 C  some constants
28280       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28281       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28282      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28283
28284 C  standard particle data interface
28285       INTEGER NMXHEP
28286
28287       PARAMETER (NMXHEP=4000)
28288
28289       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28290       DOUBLE PRECISION PHEP,VHEP
28291       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28292      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28293      &                VHEP(4,NMXHEP)
28294 C  extension to standard particle data interface (PHOJET specific)
28295       INTEGER IMPART,IPHIST,ICOLOR
28296       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28297
28298       DIMENSION PCH1(2,4)
28299       data IC1 /0/
28300       data IC2 /0/
28301
28302       IREJ = 0
28303       ILTR1 = NHEP+1
28304       IGEN = IGENM
28305       if(IGENM.le.-10) IGEN = 0
28306
28307 C  elastic part
28308       IF(IPAR.EQ.0) THEN
28309         IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28310           if(IGEN.eq.0) IGEN = 3
28311 C  pi+/pi- isotropic background
28312           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28313      &      P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28314           CALL PHO_SDECAY(IPOSH1,0,-2)
28315         ELSE
28316           if(IGEN.eq.0) then
28317             IGEN = 2
28318             if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28319           endif
28320 C  registration of particle or resonance
28321           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28322      &      P1(4),0,IGEN,0,0,IPOSH1,1)
28323         ENDIF
28324
28325 C  diffraction dissociation
28326       ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28327 C  calculation of resulting particle momenta
28328         IF(IMOTH1.EQ.NPOSD(1)) THEN
28329           K = 2
28330         ELSE
28331           K = 1
28332         ENDIF
28333         DO 100 I=1,4
28334           PCH1(2,I) = PDCMS(I,K)-P2(I)
28335           PCH1(1,I) = P1(I)-PCH1(2,I)
28336  100    CONTINUE
28337
28338 C  registration
28339         if(IMODE.LT.2) then
28340           if(IGEN.eq.0) IGEN = -IGENM/10+4
28341           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28342      &      PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28343         else
28344           if(IGEN.eq.0) IGEN = 4
28345         endif
28346         CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28347      &    PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28348
28349 C  invalid IPAR
28350       ELSE
28351         WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28352         CALL PHO_ABORT
28353       ENDIF
28354
28355 C  back transformation
28356       CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28357      &  GAMBED(1),GAMBED(2),GAMBED(3))
28358
28359       END
28360
28361 *$ CREATE PHO_QELAST.FOR
28362 *COPY PHO_QELAST
28363 CDECK  ID>, PHO_QELAST
28364       SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28365 C**********************************************************************
28366 C
28367 C     sampling of quasi elastic processes
28368 C
28369 C     input:   IPROC  2   purely elastic scattering
28370 C              IPROC  3   q-ela. omega/omega/phi/pi+pi- production
28371 C              IPROC  4   double pomeron scattering
28372 C              IPROC  -1  initialization
28373 C              IPROC  -2  output of statistics
28374 C              JM1/2      index of initial particle 1/2
28375 C
28376 C     output:  initial and final particles in /POEVT1/ involving
28377 C              polarized resonances in /POEVT1/ and decay
28378 C              products
28379 C
28380 C              IREJ    0  successful
28381 C                      1  failure
28382 C                     50  user rejection
28383 C
28384 C**********************************************************************
28385       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28386       SAVE
28387
28388       PARAMETER ( NTAB = 20,
28389      &            EPS  = 1.D-10,
28390      &            PIMASS = 0.13D0,
28391      &            DEPS = 1.D-10)
28392
28393 C  input/output channels
28394       INTEGER LI,LO
28395       COMMON /POINOU/ LI,LO
28396 C  event debugging information
28397       INTEGER NMAXD
28398       PARAMETER (NMAXD=100)
28399       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28400      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28401       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28402      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28403 C  global event kinematics and particle IDs
28404       INTEGER IFPAP,IFPAB
28405       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28406       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28407 C  c.m. kinematics of diffraction
28408       INTEGER NPOSD
28409       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28410      &                 SIDD,CODD,SIFD,COFD,PDCMS
28411       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28412      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28413 C  model switches and parameters
28414       CHARACTER*8 MDLNA
28415       INTEGER ISWMDL,IPAMDL
28416       DOUBLE PRECISION PARMDL
28417       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28418 C  some constants
28419       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28420       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28421      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28422 C  cross sections
28423       INTEGER IPFIL,IFAFIL,IFBFIL
28424       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28425      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28426      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28427      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28428      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28429       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28430      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28431      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28432      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28433      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28434      &                IPFIL,IFAFIL,IFBFIL
28435
28436 C  standard particle data interface
28437       INTEGER NMXHEP
28438
28439       PARAMETER (NMXHEP=4000)
28440
28441       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28442       DOUBLE PRECISION PHEP,VHEP
28443       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28444      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28445      &                VHEP(4,NMXHEP)
28446 C  extension to standard particle data interface (PHOJET specific)
28447       INTEGER IMPART,IPHIST,ICOLOR
28448       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28449
28450       DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28451       DIMENSION   P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28452       DIMENSION   IFL(2),IDPRO(4)
28453       character*15 pho_pname
28454       CHARACTER*8  VMESA(0:4),VMESB(0:4)
28455       DIMENSION   ISAMVM(4,4)
28456       DATA IDPRO / 113,223,333,92 /
28457       DATA VMESA / 'vmeson  ','rho     ','omega   ','phi     ',
28458      &             'pi+pi-  ' /
28459       DATA VMESB / 'vmeson  ','rho     ','omega   ','phi     ',
28460      &             'pi+pi-  ' /
28461
28462 C  sampling of elastic/quasi-elastic processes
28463       IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28464         IREJ = 0
28465         NPOSD(1) = JM1
28466         NPOSD(2) = JM2
28467         DO 55 I=1,2
28468           PMI(I) = PHEP(5,NPOSD(I))
28469           IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28470  55     CONTINUE
28471 C  get CM system
28472         PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28473         PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28474         PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28475         PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28476         SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28477         ECMD = SQRT(SS)
28478
28479         IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28480           IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28481      &      'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28482      &      ECMD,PMI
28483           IREJ = 5
28484           RETURN
28485         ENDIF
28486
28487         DO 60 I=1,4
28488           GAMBED(I) = PK1(I)/ECMD
28489  60     CONTINUE
28490         CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28491      &           PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28492      &           PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28493 C  rotation angles
28494         CODD = PK1(3)/PTOT1
28495         SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28496         COFD = 1.D0
28497         SIFD = 0.D0
28498         IF(PTOT1*SIDD.GT.1.D-5) THEN
28499           COFD = PK1(1)/(SIDD*PTOT1)
28500           SIFD = PK1(2)/(SIDD*PTOT1)
28501           ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28502           COFD = COFD/ANORF
28503           SIFD = SIFD/ANORF
28504         ENDIF
28505 C  get CM momentum
28506         AM12 = PMI(1)**2
28507         AM22 = PMI(2)**2
28508         PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28509
28510 C  production process of mother particles
28511         IGEN = IPHIST(2,NPOSD(1))
28512         if(IGEN.eq.0) IGEN = IPROC
28513
28514         ICALL = ICALL + 1
28515 C  main rejection label
28516  50     CONTINUE
28517 C  determine process and final particles
28518         IFL(1) = IDHEP(NPOSD(1))
28519         IFL(2) = IDHEP(NPOSD(2))
28520         IF(IPROC.EQ.3) THEN
28521           ITRY = 0
28522  100      CONTINUE
28523           ITRY = ITRY+1
28524           IF(ITRY.GT.50) THEN
28525             IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28526      &        'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28527      &        ITRY,ECMD
28528             IREJ = 5
28529             RETURN
28530           ENDIF
28531           XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28532           DO 110 I=1,4
28533             DO 120 J=1,4
28534               XI = XI-SIGVM(I,J)
28535               IF(XI.LE.0.D0) GOTO 130
28536  120        CONTINUE
28537  110      CONTINUE
28538  130      CONTINUE
28539           IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28540           IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28541           ISAMVM(I,J) = ISAMVM(I,J)+1
28542           ISAMQE = ISAMQE+1
28543 C  sample new masses
28544           CALL PHO_SAMASS(IFL(1),RMASS(1))
28545           CALL PHO_SAMASS(IFL(2),RMASS(2))
28546           IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28547         ELSE IF(IPROC.EQ.2) THEN
28548           I = 0
28549           J = 0
28550           ISAMEL = ISAMEL+1
28551           RMASS(1) = PHO_PMASS(NPOSD(1),2)
28552           RMASS(2) = PHO_PMASS(NPOSD(2),2)
28553         ELSE
28554           WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28555           CALL PHO_ABORT
28556         ENDIF
28557 C  sample momentum transfer
28558         CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28559      &    SLWGHT,IREJ)
28560         IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28561      &    'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28562 C  calculate new momenta
28563         CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28564         IF(IREJ.NE.0) GOTO 50
28565         DO K=1,4
28566           P(K,1) = PK1(K)
28567           P(K,2) = PK2(K)
28568         ENDDO
28569 C  comment line for elastic/quasi-elastic scattering
28570         CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28571      &    TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28572
28573         I1 = NHEP+1
28574 C  fill /POEVT1/
28575         DO 200 I=1,2
28576           K = 3-I
28577           IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28578 C  pi+/pi- isotropic background
28579             IGEN = 3
28580             CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28581      &        P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28582             ICOLOR(I,ICPOS) = IPOS
28583             CALL PHO_SDECAY(IPOS,0,-2)
28584           ELSE
28585 C  registration
28586             IGEN = 2
28587             if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28588             CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28589      &        P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28590             ICOLOR(I,ICPOS) = IPOS
28591           ENDIF
28592  200    CONTINUE
28593         I2 = NHEP
28594 C  search for vector mesons
28595         DO 300 I=I1,I2
28596 C  decay according to polarization
28597           IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28598             ISP = IPAMDL(3)
28599             IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28600             CALL PHO_SDECAY(I,ISP,2)
28601           ENDIF
28602  300    CONTINUE
28603         I2 = NHEP
28604 C  back transformation
28605         CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28606      &              GAMBED(2),GAMBED(3))
28607
28608 C  initialization of tables
28609       ELSE IF(IPROC.EQ.-1) THEN
28610         DO 10 I=1,4
28611           DO 20 J=1,4
28612             ISAMVM(I,J) = 0
28613  20       CONTINUE
28614  10     CONTINUE
28615         ISAMEL = 0
28616         ISAMQE = 0
28617         IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28618         IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28619         CALL PHO_SAMASS(-1,RMASS(1))
28620         ICALL = 0
28621
28622 C  output of statistics
28623       ELSE IF(IPROC.EQ.-2) THEN
28624         IF(ICALL.LT.10) RETURN
28625         WRITE(LO,'(/,1X,A,I10/,1X,A)')
28626      &    'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28627      &    '---------------------------------------------------'
28628         WRITE(LO,'(1X,A,I10)')
28629      &    'sampled elastic processes:',ISAMEL
28630         WRITE(LO,'(1X,A,I10)')
28631      &    'sampled quasi-elastic vectormeson production:',ISAMQE
28632         WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28633         DO 30 I=1,4
28634           WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28635  30     CONTINUE
28636         CALL PHO_SAMASS(-2,RMASS(1))
28637       ELSE
28638         WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28639      &    'unknown process ID',IPROC
28640         CALL PHO_ABORT
28641       ENDIF
28642
28643       END
28644
28645 *$ CREATE PHO_CDIFF.FOR
28646 *COPY PHO_CDIFF
28647 CDECK  ID>, PHO_CDIFF
28648       SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28649 C**********************************************************************
28650 C
28651 C     preparation of /POEVT1/ for double-pomeron scattering
28652 C
28653 C     input:   IMOTH1/2   index of mother particles in /POEVT1/
28654 C
28655 C              IMODE   1  sampling of pomeron-pomeron scattering
28656 C                     -1  initialization
28657 C                     -2  output of statistics
28658 C
28659 C     output:   MSOFT     number of generated soft strings
28660 C               MHARD     number of generated hard strings
28661 C               IREJ      0  accepted
28662 C                         1  rejected
28663 C                        50  user rejection
28664 C
28665 C**********************************************************************
28666       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28667       SAVE
28668
28669       PARAMETER ( EPS  = 1.D-10,
28670      &            DEPS = 1.D-10)
28671
28672 C  input/output channels
28673       INTEGER LI,LO
28674       COMMON /POINOU/ LI,LO
28675 C  event debugging information
28676       INTEGER NMAXD
28677       PARAMETER (NMAXD=100)
28678       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28679      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28680       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28681      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28682 C  internal rejection counters
28683       INTEGER NMXJ
28684       PARAMETER (NMXJ=60)
28685       CHARACTER*10 REJTIT
28686       INTEGER IFAIL
28687       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28688 C  model switches and parameters
28689       CHARACTER*8 MDLNA
28690       INTEGER ISWMDL,IPAMDL
28691       DOUBLE PRECISION PARMDL
28692       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28693 C  general process information
28694       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28695       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28696 C  Reggeon phenomenology parameters
28697       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28698      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28699       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28700      &                ALREG,ALREGP,GR(2),B0REG(2),
28701      &                GPPP,GPPR,B0PPP,B0PPR,
28702      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28703 C  parameters of 2x2 channel model
28704       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28705       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28706 C  some constants
28707       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28708       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28709      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28710 C  energy-interpolation table
28711       INTEGER IEETA2
28712       PARAMETER ( IEETA2 = 20 )
28713       INTEGER ISIMAX
28714       DOUBLE PRECISION SIGTAB,SIGECM
28715       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28716 C  table of particle indices for recursive PHOJET calls
28717       INTEGER MAXIPX
28718       PARAMETER ( MAXIPX = 100 )
28719       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28720       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28721      &                IPOIX1,IPOIX2,IPOIX3
28722
28723 C  standard particle data interface
28724       INTEGER NMXHEP
28725
28726       PARAMETER (NMXHEP=4000)
28727
28728       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28729       DOUBLE PRECISION PHEP,VHEP
28730       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28731      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28732      &                VHEP(4,NMXHEP)
28733 C  extension to standard particle data interface (PHOJET specific)
28734       INTEGER IMPART,IPHIST,ICOLOR
28735       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28736
28737       DIMENSION PD(4)
28738
28739       if(IMODE.ne.1) return
28740
28741       IREJ = 0
28742       IP = 4
28743 C  select first diffraction
28744       IF(DT_RNDM(DUM).GT.0.5D0) THEN
28745         IPAR1 = 1
28746         IPAR2 = 0
28747       ELSE
28748         IPAR1 = 0
28749         IPAR2 = 1
28750       ENDIF
28751       ITRY2 = 0
28752       ITRYM = 1000
28753
28754 C  save current status
28755       MSOFT = 0
28756       MHARD = 0
28757       KHPOMS = KHPOM
28758       KSPOMS = KSPOM
28759       KSREGS = KSREG
28760       KHDIRS = KHDIR
28761       IPOIS1 = IPOIX1
28762       IPOIS2 = IPOIX2
28763       IPOIS3 = IPOIX3
28764       JDA11 = JDAHEP(1,IMOTH1)
28765       JDA21 = JDAHEP(2,IMOTH1)
28766       JDA12 = JDAHEP(1,IMOTH2)
28767       JDA22 = JDAHEP(2,IMOTH2)
28768       ISTH1 = ISTHEP(IMOTH1)
28769       ISTH2 = ISTHEP(IMOTH2)
28770       NHEPS = NHEP
28771
28772 C  find mother particle production process
28773       IGEN = IPHIST(2,IMOTH1)
28774       if(IGEN.eq.0) IGEN = 4
28775
28776 C  main generation loop
28777  60   CONTINUE
28778
28779       KSPOM = KSPOMS
28780       KHPOM = KHPOMS
28781       KHDIR = KHDIRS
28782       KSREG = KSREGS
28783       I1 = IPAR1
28784       I2 = IPAR2
28785 C  reset mother-daugther relations
28786       NHEP = NHEPS
28787       JDAHEP(1,IMOTH1) = JDA11
28788       JDAHEP(2,IMOTH1) = JDA21
28789       JDAHEP(1,IMOTH2) = JDA12
28790       JDAHEP(2,IMOTH2) = JDA22
28791       ISTHEP(IMOTH1) = ISTH1
28792       ISTHEP(IMOTH2) = ISTH2
28793       IPOIX1 = IPOIS1
28794       IPOIX2 = IPOIS2
28795       IPOIX3 = IPOIS3
28796 C  rejection counter
28797       ITRY2 = ITRY2+1
28798       IF(ITRY2.GT.1) THEN
28799         IFAIL(39) = IFAIL(39)+1
28800         IF(ITRY2.GE.ITRYM) GOTO 50
28801       ENDIF
28802 C  generate two diffractive events
28803       CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28804       IF(IREJ.NE.0) GOTO 50
28805       CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28806       IF(IREJ.NE.0) GOTO 50
28807 C  mass of pomeron-pomeron system
28808       DO 100 I2 = NHEP,1,-1
28809         IF(IDHEP(I2).EQ.990) GOTO 110
28810  100  CONTINUE
28811  110  CONTINUE
28812       DO 120 I1 = I2-1,1,-1
28813         IF(IDHEP(I1).EQ.990) GOTO 130
28814  120  CONTINUE
28815  130  CONTINUE
28816       DO 140 I=1,4
28817         PD(I) = PHEP(I,I1)+PHEP(I,I2)
28818  140  CONTINUE
28819       XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28820       IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28821      &  'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28822       IF(XMASS.LT.0.1D0) GOTO 60
28823       XMASS = SQRT(XMASS)
28824       IF(XMASS.LT.PARMDL(71)) GOTO 60
28825
28826 C  sample pomeron-pomeron interaction process
28827       CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28828      &            IPROC,ISAM,JSAM,KSAM,IDIR)
28829
28830 C  non-diffractive pomeron-pomeron interactions
28831       IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28832  200    CONTINUE
28833         IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28834 C  debug output
28835         IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28836      &    'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28837      &    IP,XMASS,ISAM,JSAM,KSAM,IDIR
28838 C  store debug information
28839         IF(IDIR.GT.0) THEN
28840           IPAR = 4
28841         ELSE IF(KSAM.GT.0) THEN
28842           IPAR = 3
28843         ELSE IF(ISAM.GT.0) THEN
28844           IPAR = 2
28845         ELSE
28846           IPAR = 1
28847         ENDIF
28848         IDDPOM = IPAR
28849         IF(ISAM+JSAM.GT.0) KSDPO = 1
28850         IF(KSAM+IDIR.GT.0) KHDPO = 1
28851         KSPOM = ISAM
28852         KSREG = JSAM
28853         KHPOM = KSAM
28854         KHDIR = IDIR
28855         KSTRG = 0
28856         KSLOO = 0
28857 C  generate pomeron-pomeron interaction
28858         CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28859         IF(IREJ.NE.0) THEN
28860           IFAIL(3) = IFAIL(3)+1
28861           IF(IPAR.GT.1) THEN
28862             IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28863             IF(IDIR.GT.0) THEN
28864               IFAIL(10) = IFAIL(10)+1
28865               IDIR = 0
28866             ELSE IF(KSAM.GT.0) THEN
28867               KSAM = KSAM-1
28868             ELSE IF(ISAM.GT.0) THEN
28869               ISAM = ISAM-1
28870             ENDIF
28871             GOTO 200
28872           ELSE
28873             IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28874      &        'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28875      &        I,IPAR,XMASS
28876             GOTO 50
28877           ENDIF
28878         ENDIF
28879
28880 C  diffractive pomeron-pomeron interactions
28881       ELSE
28882         IPOIX2 = IPOIX2+1
28883         IPORES(IPOIX2)   = IPROC
28884         IPOPOS(1,IPOIX2) = I1
28885         IPOPOS(2,IPOIX2) = I2
28886         IPAR = 10+IPROC
28887         IDDPOM = IPAR
28888       ENDIF
28889
28890 C  update debug information
28891       KSPOM = KSPOMS+ISAM
28892       KSREG = KSREGS+JSAM
28893       KHPOM = KHPOMS+KSAM
28894       KHDIR = KHDIRS+IDIR
28895 C  comment line for central diffraction
28896       CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28897      &            I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28898       PHEP(5,IPOS) = XMASS
28899 C  debug output
28900       IF(IDEB(59).GE.15) THEN
28901         WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28902      &                        '-----------------------------'
28903         CALL PHO_PREVNT(0)
28904       ENDIF
28905       RETURN
28906
28907 C  treatment of rejection
28908  50   CONTINUE
28909       IREJ = 1
28910       IFAIL(40) = IFAIL(40)+1
28911       IF(IDEB(59).GE.3) THEN
28912         WRITE(LO,'(1X,A)')
28913      &    'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28914         IF(IDEB(59).GE.10) THEN
28915           CALL PHO_PREVNT(0)
28916         ELSE
28917           CALL PHO_PREVNT(-1)
28918         ENDIF
28919       ENDIF
28920
28921       END
28922
28923 *$ CREATE PHO_SAMASS.FOR
28924 *COPY PHO_SAMASS
28925 CDECK  ID>, PHO_SAMASS
28926       SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28927 C**********************************************************************
28928 C
28929 C     resonance mass sampling of quasi elastic processes
28930 C
28931 C     input:   IFLA       PDG number of particle
28932 C              IFLA   -1  initialization
28933 C              IFLA   -2  output of statistics
28934 C
28935 C     output:  RMASS      particle mass (in GeV)
28936 C
28937 C**********************************************************************
28938       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28939       SAVE
28940
28941       PARAMETER(EPS  = 1.D-10 )
28942
28943 C  input/output channels
28944       INTEGER LI,LO
28945       COMMON /POINOU/ LI,LO
28946 C  event debugging information
28947       INTEGER NMAXD
28948       PARAMETER (NMAXD=100)
28949       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28950      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28951       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28952      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28953 C  model switches and parameters
28954       CHARACTER*8 MDLNA
28955       INTEGER ISWMDL,IPAMDL
28956       DOUBLE PRECISION PARMDL
28957       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28958 C  parameters of the "simple" Vector Dominance Model
28959       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28960       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28961
28962       PARAMETER(NTABM=50)
28963       DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28964       DIMENSION SUM(4),ICALL(4)
28965
28966 C*****************************************************************
28967 C  initialization of tables
28968       IF(IFLA.EQ.-1) THEN
28969 C
28970         NSTEP = NTABM
28971         DO 102 I=1,4
28972           ICALL(I) = 0
28973
28974           DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28975           DO 105 K=1,NSTEP
28976             RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28977  105      CONTINUE
28978  102    CONTINUE
28979 C  calculate table of dsig/dm
28980         CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28981 C  output of table
28982         IF(IDEB(35).GE.1) THEN
28983           WRITE(LO,'(/5X,A)') 'table:   mass (GeV)  DSIG/DM (mub/GeV)'
28984           WRITE(LO,'(1X,A,/1X,A)')
28985      &      '  (m,  rho,     m,  omega,      m,   phi,    m,  pi+pi-)',
28986      &      ' -------------------------------------------------------'
28987           DO 106 K=1,NSTEP
28988             WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28989      &        RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28990  106      CONTINUE
28991         ENDIF
28992 C  make second table for sampling
28993         DO 109 I=1,4
28994           SUM(I) = 0.D0
28995           DO 108 K=2,NSTEP
28996             SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
28997             XMC(I,K) = SUM(I)
28998  108      CONTINUE
28999  109    CONTINUE
29000 C  normalization
29001         DO 118 K=1,NSTEP
29002           DO 119 I=1,4
29003             XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
29004  119      CONTINUE
29005  118    CONTINUE
29006         IF(IDEB(35).GE.10) THEN
29007           WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
29008           WRITE(LO,'(1X,A,/1X,A)')
29009      &      '  (m,  rho,     m,  omega,      m,   phi,    m,  pi+pi-)',
29010      &      ' -------------------------------------------------------'
29011           DO 120 K=1,NSTEP
29012             WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
29013      &        RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
29014  120      CONTINUE
29015         ENDIF
29016 C
29017 C**************************************************
29018 C  output of statistics
29019       ELSE IF(IFLA.EQ.-2) THEN
29020         WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
29021      &                        '----------------------'
29022         WRITE(LO,'(4(/8X,A,I10))') 'rho:   ',ICALL(1),
29023      &    'omega: ',ICALL(2),'phi:   ',ICALL(3),'pi+pi-:',ICALL(4)
29024
29025 C
29026 C********************************************************
29027 C  sampling of RMASS
29028       ELSE
29029 C  quasi-elastic vector meson production
29030         IF(IFLA.EQ.113) THEN
29031           KP = 1
29032         ELSE IF(IFLA.EQ.223) THEN
29033           KP = 2
29034         ELSE IF(IFLA.EQ.333) THEN
29035           KP = 3
29036         ELSE IF(IFLA.EQ.92) THEN
29037           KP = 4
29038 C  quasi-elastic production of h*
29039         ELSE IF(IFLA.EQ.91) THEN
29040           RMASS = 0.35D0
29041           RETURN
29042 C  elastic hadron scattering
29043         ELSE
29044           RMASS = PHO_PMASS(IFLA,1)
29045           IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
29046      &      'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
29047           RETURN
29048         ENDIF
29049 C
29050 C  sample mass of vector mesonsn / two-pi background
29051         XI = DT_RNDM(RMASS) + EPS
29052 C  binary search
29053         IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
29054           KMIN=1
29055           KMAX=NSTEP
29056  300      CONTINUE
29057           IF((KMAX-KMIN).EQ.1) GOTO 400
29058           KK=(KMAX+KMIN)/2
29059           IF(XI.LE.XMC(KP,KK)) THEN
29060             KMAX=KK
29061           ELSE
29062             KMIN=KK
29063           ENDIF
29064           GOTO 300
29065  400      CONTINUE
29066         ELSE
29067           WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
29068           WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
29069      &      KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
29070           CALL PHO_ABORT
29071         ENDIF
29072 C  fine interpolation
29073         RMASS = RMA(KP,KMIN)+
29074      &          (RMA(KP,KMAX)-RMA(KP,KMIN))/
29075      &          (XMC(KP,KMAX)-XMC(KP,KMIN))
29076      &          *(XI-XMC(KP,KMIN))
29077         IF(IDEB(35).GE.20) THEN
29078           IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
29079      &      'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
29080      &      RMA(KP,KMIN),RMA(KP,KMAX),RMASS
29081           WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
29082      &      IFLA,RMASS
29083         ENDIF
29084         ICALL(KP) = ICALL(KP)+1
29085
29086       ENDIF
29087       END
29088
29089 *$ CREATE PHO_DSIGDM.FOR
29090 *COPY PHO_DSIGDM
29091 CDECK  ID>, PHO_DSIGDM
29092       SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
29093 C**********************************************************************
29094 C
29095 C     differential cross section DSIG/DM of low mass enhancement
29096 C
29097 C     input:   RMA(4,NTABM)   mass values
29098 C     output:  XMA(4,NTABM)   DSIG/DM of resonances
29099 C                  1          rho production
29100 C                  2          omega production
29101 C                  3          phi production
29102 C                  4          pi-pi continuum
29103 C
29104 C**********************************************************************
29105       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29106       SAVE
29107
29108       PARAMETER ( EPS  = 1.D-10 )
29109
29110       PARAMETER(NTABM=50)
29111       DIMENSION XMA(4,NTABM),RMA(4,NTABM)
29112
29113 C  input/output channels
29114       INTEGER LI,LO
29115       COMMON /POINOU/ LI,LO
29116 C  event debugging information
29117       INTEGER NMAXD
29118       PARAMETER (NMAXD=100)
29119       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29120      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29121       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29122      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29123 C  model switches and parameters
29124       CHARACTER*8 MDLNA
29125       INTEGER ISWMDL,IPAMDL
29126       DOUBLE PRECISION PARMDL
29127       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29128 C  parameters of the "simple" Vector Dominance Model
29129       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29130       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29131
29132       PIMASS = 0.135
29133 C  rho meson shape (mass dependent width)
29134       QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
29135       DO 100 I=1,NSTEP
29136         XMASS = RMA(1,I)
29137         QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
29138         GAMMA = GAMM(1)*(QQ/QRES)**3
29139         XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
29140      &             /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
29141  100  CONTINUE
29142 C  omega/phi meson (constant width)
29143       DO 200 K=2,3
29144         DO 300 I=1,NSTEP
29145           XMASS = RMA(K,I)
29146           XMA(K,I) = XMASS*GAMM(K)
29147      &               /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
29148  300    CONTINUE
29149  200  CONTINUE
29150 C  pi-pi continuum
29151       DO 400 I=1,NSTEP
29152         XMASS = RMA(4,I)
29153         XMA(4,I) = (XMASS-0.29D0)**2/XMASS
29154  400  CONTINUE
29155
29156       END
29157
29158 *$ CREATE PHO_SDECAY.FOR
29159 *COPY PHO_SDECAY
29160 CDECK  ID>, PHO_SDECAY
29161       SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
29162 C**********************************************************************
29163 C
29164 C     decay of single resonance of /POEVT1/:
29165 C       decay in helicity frame according to polarization, isotropic
29166 C       decay and decay with limited transverse phase space possible
29167 C
29168 C     ATTENTION:
29169 C     reference to particle number of CPC has to exist
29170 C
29171 C     input:   NPOS    position in /POEVT1/
29172 C              ISP     0  decay according to phase space
29173 C                      1  decay according to transversal polarization
29174 C                      2  decay according to longitudinal polarization
29175 C                      3  decay with limited phase space
29176 C              ILEV    decay mode to use
29177 C                      1 strong only
29178 C                      2 strong and ew of tau, charm, and bottom
29179 C                      3 strong and electro-weak decays
29180 C                      negative: remove mother resonance after decay
29181 C
29182 C     output:  /POEVT1/,/POEVT2/ final particles according to decay mode
29183 C
29184 C**********************************************************************
29185       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29186       SAVE
29187
29188       PARAMETER ( EPS  = 1.D-15,
29189      &            DEPS = 1.D-10 )
29190
29191 C  input/output channels
29192       INTEGER LI,LO
29193       COMMON /POINOU/ LI,LO
29194 C  event debugging information
29195       INTEGER NMAXD
29196       PARAMETER (NMAXD=100)
29197       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29198      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29199       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29200      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29201 C  model switches and parameters
29202       CHARACTER*8 MDLNA
29203       INTEGER ISWMDL,IPAMDL
29204       DOUBLE PRECISION PARMDL
29205       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29206 C  some constants
29207       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29208       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29209      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29210
29211 C  standard particle data interface
29212       INTEGER NMXHEP
29213
29214       PARAMETER (NMXHEP=4000)
29215
29216       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
29217       DOUBLE PRECISION PHEP,VHEP
29218       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
29219      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
29220      &                VHEP(4,NMXHEP)
29221 C  extension to standard particle data interface (PHOJET specific)
29222       INTEGER IMPART,IPHIST,ICOLOR
29223       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
29224
29225 C  general particle data
29226       double precision xm_list,tau_list,gam_list,
29227      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29228      &  xm_bb82_list,xm_bb102_list
29229       integer          ich3_list,iba3_list,iq_list,
29230      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
29231       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29232      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
29233      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29234      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29235      &  ich3_list(300),iba3_list(300),iq_list(3,300),
29236      &  id_psm_list(6,6),id_vem_list(6,6),
29237      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
29238 C  particle decay data
29239       double precision wg_sec_list
29240       integer          idec_list,isec_list
29241       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
29242      &  isec_list(3,500)
29243 C  auxiliary data for three particle decay
29244       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29245       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29246
29247       DIMENSION WGHD(20),KCH(20),ID(3)
29248
29249       IMODE = ABS(ILEV)
29250       IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
29251      &  'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
29252
29253 C  comment entry
29254       IF(ISTHEP(NPOS).GT.11) RETURN
29255
29256 C  particle stable?
29257       IDcpc = IMPART(NPOS)
29258       IF(IDcpc.EQ.0) return
29259       IDabs = iabs(IDcpc)
29260       if(idec_list(1,IDabs).eq.0) return
29261
29262 C  different decay modi (times)
29263       IF(IMODE.EQ.1) THEN
29264         if(idec_list(1,IDabs).ne.1) return
29265       ELSE IF(IMODE.EQ.2) THEN
29266         if(idec_list(1,IDabs).gt.2) return
29267       ELSE IF(IMODE.EQ.3) THEN
29268         if(idec_list(1,IDabs).gt.3) return
29269       ELSE
29270         WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
29271         CALL PHO_ABORT
29272       ENDIF
29273
29274 C  decay products, check for mass limitations
29275       K = 0
29276       WGSUM = 0.D0
29277       AMIST = PHEP(5,NPOS)
29278       DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
29279         AMSUM = 0.D0
29280         DO 200 L=1,3
29281           ID(L) = isec_list(L,I)
29282           IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
29283  200    CONTINUE
29284         IF(AMSUM.LT.AMIST) THEN
29285           K = K+1
29286           WGHD(K) = wg_sec_list(I)
29287           KCH(K) = I
29288         ENDIF
29289  100  CONTINUE
29290       IF(K.EQ.0)THEN
29291         WRITE(LO,'(/1X,A,I6,3E12.4)')
29292      &    'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29293      &    NPOS,AMIST,AMSUM
29294         CALL PHO_PREVNT(0)
29295         RETURN
29296       ENDIF
29297
29298 C  sample new decay channel
29299       XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29300       K = 0
29301       WGSUM = 0.D0
29302  500  CONTINUE
29303         K = K+1
29304         WGSUM = WGSUM+WGHD(K)
29305       IF(XI.GT.WGSUM) GOTO 500
29306       IK = KCH(K)
29307       ID(1) = isec_list(1,IK)
29308       ID(2) = isec_list(2,IK)
29309       ID(3) = isec_list(3,IK)
29310       if(IDcpc.lt.0) then
29311         ID(1) = ipho_anti(ID(1))
29312         ID(2) = ipho_anti(ID(2))
29313         if(ID(3).ne.0) ID(3) = ipho_anti(ID(3))
29314       endif
29315
29316 C  rotation
29317       PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29318       CXS = PHEP(1,NPOS)/PTOT
29319       CYS = PHEP(2,NPOS)/PTOT
29320       CZS = PHEP(3,NPOS)/PTOT
29321 C  boost
29322       GBET = PTOT/AMIST
29323       GAM = PHEP(4,NPOS)/AMIST
29324
29325       IF(ID(3).EQ.0) THEN
29326 C  two particle decay
29327         CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29328       ELSE
29329 C  three particle decay
29330         CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29331      &    pho_pmass(ID(3),0),ISP)
29332       ENDIF
29333
29334       IF(ILEV.LT.0) THEN
29335         IF(NHEP.NE.NPOS) THEN
29336           WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29337      &      'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29338           CALL PHO_ABORT
29339         ENDIF
29340         IMO1 = JMOHEP(1,NPOS)
29341         IMO2 = JMOHEP(2,NPOS)
29342         NHEP = NHEP-1
29343       ELSE
29344         IMO1 = NPOS
29345         IMO2 = 0
29346       ENDIF
29347       IPH1 = IPHIST(1,NPOS)
29348       IPH2 = IPHIST(2,NPOS)
29349
29350 C  back transformation and registration
29351       DO 300 I=1,3
29352         IF(ID(I).NE.0) THEN
29353           CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29354      &      PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29355           XX = PTOT*CX
29356           YY = PTOT*CY
29357           ZZ = PTOT*CZ
29358           CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29359      &      IPH1,IPH2,0,0,IPOS,1)
29360         ENDIF
29361  300  CONTINUE
29362
29363  400  CONTINUE
29364 C  debug output
29365       IF(IDEB(36).GE.20) THEN
29366         WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29367      &                        '--------------------'
29368         CALL PHO_PREVNT(0)
29369       ENDIF
29370
29371       END
29372
29373 *$ CREATE PHO_SDECY2.FOR
29374 *COPY PHO_SDECY2
29375 CDECK  ID>, PHO_SDECY2
29376       SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29377 C**********************************************************************
29378 C
29379 C     isotropic/anisotropic two particle decay in CM system,
29380 C     (transversely/longitudinally polarized boson into two
29381 C     pseudo-scalar mesons)
29382 C
29383 C**********************************************************************
29384       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29385       SAVE
29386
29387 C  input/output channels
29388       INTEGER LI,LO
29389       COMMON /POINOU/ LI,LO
29390 C  auxiliary data for three particle decay
29391       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29392       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29393
29394       UMO2=UMO*UMO
29395       AM11=AM1*AM1
29396       AM22=AM2*AM2
29397       ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29398       ECM(2)=UMO-ECM(1)
29399       WAU=ECM(1)*ECM(1)-AM11
29400       IF(WAU.LT.0.D0) THEN
29401         WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29402         CALL PHO_ABORT
29403       ENDIF
29404       PCM(1)=SQRT(WAU)
29405       PCM(2)=PCM(1)
29406
29407       CALL PHO_SFECFE(SIF(1),COF(1))
29408       IF(ISP.EQ.0) THEN
29409 C  no polarization
29410         COD(1)  = 2.D0*DT_RNDM(UMO)-1.D0
29411       ELSE IF(ISP.EQ.1) THEN
29412 C  transverse polarization
29413  400    CONTINUE
29414           COD(1)  = 2.D0*DT_RNDM(AM22)-1.D0
29415           SID12 = 1.D0-COD(1)*COD(1)
29416         IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29417       ELSE IF(ISP.EQ.2) THEN
29418 C  longitudinal polarization
29419  500    CONTINUE
29420           COD(1)  = 2.D0*DT_RNDM(AM2)-1.D0
29421           COD12 = COD(1)*COD(1)
29422         IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29423       ELSE
29424         WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29425      &    'invalid polarization',ISP
29426         CALL PHO_ABORT
29427       ENDIF
29428
29429       COD(2) = -COD(1)
29430       COF(2) = -COF(1)
29431       SIF(2) = -SIF(1)
29432
29433       END
29434
29435 *$ CREATE PHO_SDECY3.FOR
29436 *COPY PHO_SDECY3
29437 CDECK  ID>, PHO_SDECY3
29438       SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29439 C**********************************************************************
29440 C
29441 C     isotropic/anisotropic three particle decay in CM system,
29442 C     (transversely/longitudinally polarized boson into three
29443 C     pseudo-scalar mesons)
29444 C
29445 C**********************************************************************
29446       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29447       SAVE
29448
29449       PARAMETER ( DEPS   = 1.D-30,
29450      &            EPS    = 1.D-15 )
29451
29452 C  input/output channels
29453       INTEGER LI,LO
29454       COMMON /POINOU/ LI,LO
29455 C  auxiliary data for three particle decay
29456       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29457       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29458
29459       DIMENSION F(5),XX(5)
29460
29461 C  calculation of maximum of S2 phase space weight
29462       UMOO=UMO+UMO
29463       GU=(AM2+AM3)**2
29464       GO=(UMO-AM1)**2
29465       UFAK=1.0000000000001D0
29466       IF (GU.GT.GO) UFAK=0.99999999999999D0
29467       OFAK=2.D0-UFAK
29468       GU=GU*UFAK
29469       GO=GO*OFAK
29470       DS2=(GO-GU)/99.D0
29471       AM11=AM1*AM1
29472       AM22=AM2*AM2
29473       AM33=AM3*AM3
29474       UMO2=UMO*UMO
29475       RHO2=0.D0
29476       S22=GU
29477       DO 124 I=1,100
29478         S21=S22
29479         S22=GU+(I-1.D0)*DS2
29480         RHO1=RHO2
29481         RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29482         IF(RHO2.LT.RHO1) GOTO 125
29483   124 CONTINUE
29484
29485   125 CONTINUE
29486       S2SUP=(S22-S21)/2.D0+S21
29487       SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29488      &       /(S2SUP+EPS)
29489       SUPRHO=SUPRHO*1.05D0
29490       XO=S21-DS2
29491       IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29492       IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29493       XX(1)=XO
29494       XX(3)=S22
29495       X1=(XO+S22)*0.5D0
29496       XX(2)=X1
29497       F(3)=RHO2
29498       F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29499       F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29500       DO 126 I=1,16
29501         X4=(XX(1)+XX(2))*0.5D0
29502         X5=(XX(2)+XX(3))*0.5D0
29503         F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29504         F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29505         XX(4)=X4
29506         XX(5)=X5
29507         DO 128 II=1,5
29508           IA=II
29509           DO 131 III=IA,5
29510             IF(F(II).LT.F(III)) THEN
29511               FH=F(II)
29512               F(II)=F(III)
29513               F(III)=FH
29514               FH=XX(II)
29515               XX(II)=XX(III)
29516               XX(III)=FH
29517             ENDIF
29518  131      CONTINUE
29519  128    CONTINUE
29520         SUPRHO=F(1)
29521         S2SUP=XX(1)
29522         DO 129 II=1,3
29523           IA=II
29524           DO 130 III=IA,3
29525             IF (XX(II).LT.XX(III)) THEN
29526               FH=F(II)
29527               F(II)=F(III)
29528               F(III)=FH
29529               FH=XX(II)
29530               XX(II)=XX(III)
29531               XX(III)=FH
29532             ENDIF
29533  130      CONTINUE
29534  129    CONTINUE
29535  126  CONTINUE
29536
29537       AM23=(AM2+AM3)**2
29538
29539 C  selection of S1
29540       ITH=0
29541  200  CONTINUE
29542         ITH=ITH+1
29543         IF(ITH.GT.200) THEN
29544           WRITE(LO,'(/1X,A,I10)')
29545      &      'PHO_SDECY3:ERROR: too many iterations',ITH
29546           CALL PHO_ABORT
29547         ENDIF
29548         S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29549         Y=DT_RNDM(AM23)*SUPRHO
29550         RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29551       IF(Y.GT.RHO) GOTO 200
29552
29553 C  selection of S2
29554       S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29555      &   /(2.D0*S2)-RHO/2.D0
29556       S3=UMO2+AM11+AM22+AM33-S1-S2
29557       ECM(1)=(UMO2+AM11-S2)/UMOO
29558       ECM(2)=(UMO2+AM22-S3)/UMOO
29559       ECM(3)=(UMO2+AM33-S1)/UMOO
29560       PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29561       PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29562       PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29563
29564 C  calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29565       IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29566         COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29567       ELSE
29568         COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29569       ENDIF
29570       COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29571      &        /(2.D0*PCM(2)*PCM(3))
29572       SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29573       SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29574       COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29575
29576 C  selection of the sperical coordinates of particle 3
29577       CALL PHO_SFECFE(SIF(3),COF(3))
29578       IF(ISP.EQ.0) THEN
29579 C  no polarization
29580         COD(3)  = 2.D0*DT_RNDM(S2)-1.D0
29581       ELSE IF(ISP.EQ.1) THEN
29582 C  transverse polarization
29583  400    CONTINUE
29584           COD(3)  = 2.D0*DT_RNDM(S1)-1.D0
29585           SID32 = 1.D0-COD(3)*COD(3)
29586         IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29587       ELSE IF(ISP.EQ.2) THEN
29588 C  longitudinal polarization
29589  500    CONTINUE
29590           COD(3)  = 2.D0*DT_RNDM(COSTH2)-1.D0
29591           COD32 = COD(3)*COD(3)
29592         IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29593       ELSE
29594         WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29595      &    'invalid polarization',ISP
29596         CALL PHO_ABORT
29597       ENDIF
29598
29599 C  selection of the rotation angle of p1-p2 plane along p3
29600       IF(ISP.EQ.0) THEN
29601         CALL PHO_SFECFE(SFE,CFE)
29602       ELSE
29603         SFE = 0.D0
29604         CFE = 1.D0
29605       ENDIF
29606       CX11=-COSTH1
29607       CY11=SINTH1*CFE
29608       CZ11=SINTH1*SFE
29609       CX22=-COSTH2
29610       CY22=-SINTH2*CFE
29611       CZ22=-SINTH2*SFE
29612
29613       SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29614       COD(1)=CX11*COD(3)+CZ11*SID3
29615       IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29616         WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29617      &    COD(1),COF(3),SID3,CX11,CZ11
29618         CALL PHO_PREVNT(-1)
29619       ENDIF
29620
29621       SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29622       COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29623       SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29624       COD(2)=CX22*COD(3)+CZ22*SID3
29625       SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29626       COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29627       SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29628
29629       END
29630
29631 *$ CREATE PHO_DFMASS.FOR
29632 *COPY PHO_DFMASS
29633 CDECK  ID>, PHO_DFMASS
29634       DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29635 C**********************************************************************
29636 C
29637 C     sampling of Mx diffractive mass distribution within
29638 C              limits XMIN, XMAX
29639 C
29640 C     input:    XMIN,XMAX     mass limitations (GeV)
29641 C               PREF2         original particle mass/ reference mass
29642 C                             (squared, GeV**2)
29643 C               PVIRT2        particle virtuality
29644 C               IMODE         M**2 mass distribution
29645 C                             1      1/(M**2+Q**2)
29646 C                             2      1/(M**2+Q**2)**alpha
29647 C                            -1      1/(M**2-Mref**2+Q**2)
29648 C                            -2      1/(M**2-Mref**2+Q**2)**alpha
29649 C
29650 C     output:   diffractive mass (GeV)
29651 C
29652 C**********************************************************************
29653       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29654       SAVE
29655
29656       PARAMETER(EPS  = 1.D-10)
29657
29658 C  input/output channels
29659       INTEGER LI,LO
29660       COMMON /POINOU/ LI,LO
29661 C  event debugging information
29662       INTEGER NMAXD
29663       PARAMETER (NMAXD=100)
29664       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29665      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29666       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29667      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29668 C  model switches and parameters
29669       CHARACTER*8 MDLNA
29670       INTEGER ISWMDL,IPAMDL
29671       DOUBLE PRECISION PARMDL
29672       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29673 C  some constants
29674       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29675       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29676      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29677
29678       IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29679         WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29680      &    'invalid mass limits',XMIN,XMAX,PREF2
29681         CALL PHO_PREVNT(-1)
29682         PHO_DFMASS = 0.135D0
29683         RETURN
29684       ENDIF
29685
29686       IF(IMODE.GT.0) THEN
29687         PM2 = -PVIRT2
29688       ELSE
29689         PM2 = PREF2 - PVIRT2
29690       ENDIF
29691
29692 C  critical pomeron
29693       IF(ABS(IMODE).EQ.1) THEN
29694         XMIN2 = LOG(XMIN**2-PM2)
29695         XMAX2 = LOG(XMAX**2-PM2)
29696         XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29697         XMA2 = EXP(XI)+PM2
29698
29699 C  supercritical pomeron
29700       ELSE IF(ABS(IMODE).EQ.2) THEN
29701         DDELTA = 1.D0-PARMDL(48)
29702         XMIN2 = (XMIN**2-PM2)**DDELTA
29703         XMAX2 = (XMAX**2-PM2)**DDELTA
29704         XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29705         XMA2 = XI**(1.D0/DDELTA)+PM2
29706       ELSE
29707         WRITE(LO,'(/,1X,A,I3)')
29708      &    'PHO_DFMASS:ERROR: unsupported mode',IMODE
29709         CALL PHO_ABORT
29710       ENDIF
29711
29712       PHO_DFMASS = SQRT(XMA2)
29713 C  debug output
29714       IF(IDEB(43).GE.15) THEN
29715         WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29716      &    XMIN,XMAX,PREF2,SQRT(XMA2)
29717       ENDIF
29718
29719       END
29720
29721 *$ CREATE PHO_DIFSLP.FOR
29722 *COPY PHO_DIFSLP
29723 CDECK  ID>, PHO_DIFSLP
29724       SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29725      &                  TT,SLWGHT,IREJ)
29726 C**********************************************************************
29727 C
29728 C     sampling of T  (Mandelstam variable) distribution within
29729 C     certain limits TMIN, TMAX
29730 C
29731 C     input:    IDF1,2     type of diffractive vertex
29732 C                           0   elastic/quasi-elastic scattering
29733 C                           1   diffraction dissociation
29734 C               IVEC1,2    vector meson IDs in case of quasi-elastic
29735 C                          scattering, otherwise 0
29736 C               XM1        mass of diffractive system 1 (GeV)
29737 C               XM2        mass of diffractive system 2 (GeV)
29738 C               XMX        max. mass of diffractive system (GeV)
29739 C
29740 C     output:   TT         squared momentum transfer ( < 0, GeV**2)
29741 C               SLWGHT     weight to allow for mass-dependent slope
29742 C               IREJ       0  successful sampling
29743 C                          1  masses too big for given T range
29744 C
29745 C**********************************************************************
29746       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29747       SAVE
29748
29749       PARAMETER(EPS  = 1.D-10)
29750
29751 C  input/output channels
29752       INTEGER LI,LO
29753       COMMON /POINOU/ LI,LO
29754 C  event debugging information
29755       INTEGER NMAXD
29756       PARAMETER (NMAXD=100)
29757       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29758      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29759       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29760      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29761 C  model switches and parameters
29762       CHARACTER*8 MDLNA
29763       INTEGER ISWMDL,IPAMDL
29764       DOUBLE PRECISION PARMDL
29765       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29766 C  internal rejection counters
29767       INTEGER NMXJ
29768       PARAMETER (NMXJ=60)
29769       CHARACTER*10 REJTIT
29770       INTEGER IFAIL
29771       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29772 C  c.m. kinematics of diffraction
29773       INTEGER NPOSD
29774       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29775      &                 SIDD,CODD,SIFD,COFD,PDCMS
29776       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29777      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29778 C  cross sections
29779       INTEGER IPFIL,IFAFIL,IFBFIL
29780       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29781      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29782      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29783      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29784      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29785       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29786      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29787      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29788      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29789      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29790      &                IPFIL,IFAFIL,IFBFIL
29791 C  Reggeon phenomenology parameters
29792       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29793      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29794       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29795      &                ALREG,ALREGP,GR(2),B0REG(2),
29796      &                GPPP,GPPR,B0PPP,B0PPR,
29797      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29798 C  parameters of 2x2 channel model
29799       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29800       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29801 C  parameters of the "simple" Vector Dominance Model
29802       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29803       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29804 C  some constants
29805       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29806       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29807      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29808
29809       IREJ = 0
29810       XM12 = XM1**2
29811       XM22 = XM2**2
29812       SS = ECMD**2
29813 C
29814 C  range of momentum transfer t
29815       TMIN = -PARMDL(68)
29816       TMAX = -PARMDL(69)
29817 C  determine min. abs(t) necessary to produce masses
29818       PCM2 = PCMD**2
29819       PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29820       IF(PCMP2.LE.0.D0) THEN
29821         IREJ = 1
29822         TT = 0.D0
29823         RETURN
29824       ENDIF
29825       TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29826      &        -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29827 C
29828       IF(TMINP.LT.TMAX) THEN
29829         IF(IDEB(44).GE.3) THEN
29830           WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29831      &      'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29832      &      XM1,XM2,TMIN,TMAX,TMINP
29833         ENDIF
29834         IFAIL(32) = IFAIL(32)+1
29835         IREJ = 1
29836         TT = 0.D0
29837         RETURN
29838       ENDIF
29839       TMINA = MIN(TMIN,TMINP)
29840 C
29841 C  calculation of slope (mass-dependent parametrization)
29842       IF(IDF1+IDF2.GT.0) THEN
29843 C  diffraction dissociation
29844         XMP12 = XM1**2+PVIRTD(1)
29845         XMP22 = XM2**2+PVIRTD(2)
29846         XMX1 = SQRT(XMP12)
29847         XMX2 = SQRT(XMP22)
29848         CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29849         FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29850         SLOPE = DBLE(IDF1+IDF2)*B0PPP
29851      &    +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29852      &    /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29853         SLOPE = MAX(SLOPE,1.D0)
29854 C
29855         XMA1 = XMX
29856         XMA2 = XMX
29857         IF(IDF1.EQ.0) THEN
29858           XMA1 = XM1
29859         ELSE IF(IDF1.EQ.0) THEN
29860           XMA2 = XM2
29861         ENDIF
29862         XMP12 = XMA1**2+PVIRTD(1)
29863         XMP22 = XMA2**2+PVIRTD(2)
29864         XMX1 = SQRT(XMP12)
29865         XMX2 = SQRT(XMP22)
29866         CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29867         SLMIN = DBLE(IDF1+IDF2)*B0PPP
29868      &    +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29869      &    /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29870         SLMIN = MAX(SLMIN,1.D0)
29871       ELSE
29872 C  elastic/quasi-elastic scattering
29873         IF(ISWMDL(13).EQ.0) THEN
29874 C  external slope values
29875 C          PRINT LO,'PHO_DIFSLP:ERROR: this option is not installed !'
29876           CALL PHO_ABORT
29877         ELSE IF(ISWMDL(13).EQ.1) THEN
29878 C  model slopes
29879           IF(IVEC1*IVEC2.EQ.0) THEN
29880             SLOPE = SLOEL
29881           ELSE
29882             SLOPE = SLOVM(IVEC1,IVEC2)
29883           ENDIF
29884           SLMIN = SLOPE
29885         ELSE
29886           WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29887      &      ISWMDL(13)
29888           CALL PHO_ABORT
29889         ENDIF
29890       ENDIF
29891 C
29892 C  determine max. abs(t) to avoid underflows
29893       TMAXP = -25.D0/SLOPE
29894       TMAXA = MAX(TMAX,TMAXP)
29895 C
29896       IF(TMINA.LT.TMAXA) THEN
29897         IF(IDEB(44).GE.3) THEN
29898           WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29899      &      'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29900      &      XM1,XM2,TMINA,TMAXA,SLOPE
29901         ENDIF
29902         IFAIL(32) = IFAIL(32)+1
29903         IREJ = 1
29904         TT = 0.D0
29905         RETURN
29906       ENDIF
29907 C
29908 C  sampling from corrected range of T
29909       TMINE = EXP(SLMIN*TMINA)
29910       TMAXE = EXP(SLMIN*TMAXA)
29911       XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29912       TT = LOG(XI)/SLMIN
29913       SLWGHT = EXP((SLOPE-SLMIN)*TT)
29914 C
29915 C  debug output
29916       IF(IDEB(44).GE.15) THEN
29917         WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29918      &    'PHO_DIFSLP: sampled momentum transfer:',TT,
29919      &    'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29920      &    'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29921       ENDIF
29922       END
29923
29924 *$ CREATE PHO_DIFKIN.FOR
29925 *COPY PHO_DIFKIN
29926 CDECK  ID>, PHO_DIFKIN
29927       SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29928 C**********************************************************************
29929 C
29930 C     calculation of diffractive kinematics
29931 C
29932 C     input:    XMP1         mass of outgoing particle system 1 (GeV)
29933 C               XMP2         mass of outgoing particle system 2 (GeV)
29934 C               TT           momentum transfer    (GeV**2, negative)
29935 C
29936 C     output:   PMOM1(5)     four momentum of outgoing system 1
29937 C               PMOM2(5)     four momentum of outgoing system 2
29938 C               IREJ         0    kinematics consistent
29939 C                            1    kinematics inconsistent
29940 C
29941 C**********************************************************************
29942       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29943       SAVE
29944
29945       PARAMETER(EPS  = 1.D-10,
29946      &          DEPS = 0.001)
29947
29948 C  input/output channels
29949       INTEGER LI,LO
29950       COMMON /POINOU/ LI,LO
29951 C  event debugging information
29952       INTEGER NMAXD
29953       PARAMETER (NMAXD=100)
29954       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29955      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29956       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29957      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29958 C  c.m. kinematics of diffraction
29959       INTEGER NPOSD
29960       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29961      &                 SIDD,CODD,SIFD,COFD,PDCMS
29962       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29963      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29964 C  some constants
29965       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29966       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29967      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29968
29969       DOUBLE PRECISION PMOM1,PMOM2
29970       DIMENSION PMOM1(5),PMOM2(5)
29971
29972 C  debug output
29973       IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29974      &    'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29975      &    ECMD,PCMD,XMP1,XMP2,TT
29976
29977 C  general kinematic constraints
29978       IREJ = 1
29979       IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29980
29981 C  new squared cms momentum
29982       XMP12 = XMP1**2
29983       XMP22 = XMP2**2
29984       SS = ECMD**2
29985       PCM2 = PCMD**2
29986       PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29987
29988 C  new longitudinal/transverse momentum
29989       E1I = SQRT(PCM2+PMASSD(1)**2)
29990       E1F = SQRT(PCMP2+XMP12)
29991       E2F = SQRT(PCMP2+XMP22)
29992       PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29993       PTRAN = PCMP2-PLONG**2
29994
29995 C  check consistency of kinematics
29996       IF(PTRAN.LT.0.D0) THEN
29997         IF(IDEB(49).GE.1) THEN
29998           WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29999      &      'inconsistent kinematics in event call: ',KEVENT
30000           WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
30001      &      'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
30002      &      XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
30003         ENDIF
30004         IREJ = 1
30005         RETURN
30006       ELSE
30007         PTRAN = SQRT(PTRAN)
30008       ENDIF
30009       XI = PI2*DT_RNDM(PTRAN)
30010
30011 C  outgoing momenta in cm. system
30012       PMOM1(4) = E1F
30013       PMOM1(1) = PTRAN*COS(XI)
30014       PMOM1(2) = PTRAN*SIN(XI)
30015       PMOM1(3) = PLONG
30016       PMOM1(5) = XMP1
30017
30018       PMOM2(4) = E2F
30019       PMOM2(1) = -PMOM1(1)
30020       PMOM2(2) = -PMOM1(2)
30021       PMOM2(3) = -PLONG
30022       PMOM2(5) = XMP2
30023       IREJ = 0
30024
30025 C  debug output / precision check
30026       IF(IDEB(49).GE.0) THEN
30027 C  check kinematics
30028         XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
30029      &        -PMOM1(1)**2-PMOM1(2)**2
30030         XM1 = SIGN(SQRT(ABS(XM1)),XM1)
30031         XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
30032      &        -PMOM2(1)**2-PMOM2(2)**2
30033         XM2 = SIGN(SQRT(ABS(XM2)),XM2)
30034         IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
30035           WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
30036      &      'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
30037      &      XMP1,XM1,XMP2,XM2
30038           CALL PHO_PREVNT(-1)
30039         ENDIF
30040 C  output
30041         IF(IDEB(49).GT.10) THEN
30042           WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
30043      &      'PHO_DIFKIN: P1',PMOM1,'                 P2',PMOM2
30044         ENDIF
30045       ENDIF
30046
30047       END
30048
30049 *$ CREATE PHO_VECRES.FOR
30050 *COPY PHO_VECRES
30051 CDECK  ID>, PHO_VECRES
30052       SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
30053 C**********************************************************************
30054 C
30055 C     sampling of vector meson resonance in diffractive processes
30056 C     (nothing done for hadrons)
30057 C
30058 C     input:   /POSVDM/     VDMFAC factors
30059 C
30060 C     output:  IVEC         0   incoming hadron
30061 C                           1   rho 0
30062 C                           2   omega
30063 C                           3   phi
30064 C                           4   pi+/pi- background
30065 C              RMASS        mass of vector meson (GeV)
30066 C              IDPDG        particle ID according to PDG
30067 C              IDBAM        particle ID according to CPC
30068 C
30069 C**********************************************************************
30070       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30071       SAVE
30072
30073       PARAMETER(EPS  = 1.D-10)
30074
30075 C  input/output channels
30076       INTEGER LI,LO
30077       COMMON /POINOU/ LI,LO
30078 C  event debugging information
30079       INTEGER NMAXD
30080       PARAMETER (NMAXD=100)
30081       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30082      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30083       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30084      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30085 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
30086       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30087       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30088       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30089      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30090 C  parameters of the "simple" Vector Dominance Model
30091       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
30092       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
30093 C  some constants
30094       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30095       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30096      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30097
30098 C  particle code translation
30099       DIMENSION ITRANS(4)
30100 C                  rho0,omega,phi,pi+/pi-
30101       DATA ITRANS /113, 223, 333, 92 /
30102
30103       IDPDO = IDPDG
30104 C
30105 C  vector meson production
30106       IF(IDPDG.EQ.22) THEN
30107         XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
30108         SUM = 0.D0
30109         DO 55 K=1,4
30110           SUM = SUM + VMFA(K)
30111           IF(XI.LE.SUM) GOTO 65
30112  55     CONTINUE
30113  65     CONTINUE
30114 C
30115         IDPDG = ITRANS(K)
30116         IDBAM = ipho_pdg2id(IDPDG)
30117         IVEC  = K
30118 C  sample mass of vector meson
30119         CALL PHO_SAMASS(IDPDG,RMASS)
30120
30121 C  hadronic resonance of multi-pomeron coupling
30122       ELSE IF(IDPDG.EQ.990) THEN
30123         K = 4
30124         IDPDG = 91
30125         IDBAM = ipho_pdg2id(IDPDG)
30126         IVEC  = 4
30127 C  sample mass of two-pion system
30128         CALL PHO_SAMASS(IDPDG,RMASS)
30129
30130 C  hadron remnants in inucleus interactions
30131       ELSE IF(IDPDG.EQ.81) THEN
30132         IF(IHFLD(1,1).EQ.0) THEN
30133           CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
30134           CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
30135         ELSE
30136           CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
30137         ENDIF
30138         RMAS1 = PHO_PMASS(IDBA1,0)
30139         RMAS2 = PHO_PMASS(IDBA2,0)
30140         IF((IDBA2.NE.0).AND.
30141      &    (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
30142           IDBAM = IDBA2
30143           RMASS = RMAS2
30144         ELSE
30145           IDBAM = IDBA1
30146           RMASS = RMAS1
30147         ENDIF
30148         IDPDG = IPHO_ID2PDG(IDBAM)
30149         IVEC = 0
30150       ELSE IF(IDPDG.EQ.82) THEN
30151         IF(IHFLD(2,1).EQ.0) THEN
30152           CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
30153           CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
30154         ELSE
30155           CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
30156         ENDIF
30157         RMAS1 = PHO_PMASS(IDBA1,0)
30158         RMAS2 = PHO_PMASS(IDBA2,0)
30159         IF((IDBA2.NE.0).AND.
30160      &    (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
30161           IDBAM = IDBA2
30162           RMASS = RMAS2
30163         ELSE
30164           IDBAM = IDBA1
30165           RMASS = RMAS1
30166         ENDIF
30167         IDPDG = IPHO_ID2PDG(IDBAM)
30168         IVEC = 0
30169       ENDIF
30170 C  debug output
30171       IF(IDEB(47).GE.5) THEN
30172         WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
30173      &    'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
30174      &    IDPDO,IDPDG,IDBAM,RMASS
30175       ENDIF
30176
30177       END
30178
30179 *$ CREATE PHO_DIFRES.FOR
30180 *COPY PHO_DIFRES
30181 CDECK  ID>, PHO_DIFRES
30182       SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
30183      &                  IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
30184 C**********************************************************************
30185 C
30186 C     list of resonance states for low mass resonances
30187 C
30188 C     input:   IDMOTH       PDG ID of mother particle
30189 C              IVAL1,2      quarks (photon only)
30190 C
30191 C     output:  IDPDG        list of PDG IDs for possible resonances
30192 C              IDBAM        list of corresponding CPC IDs
30193 C              RMASS        mass
30194 C              RGAMS        decay width
30195 C              RMASS        additional weight factor
30196 C              LISTL        entries in current list
30197 C
30198 C**********************************************************************
30199       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30200       SAVE
30201
30202       DIMENSION  IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
30203
30204       PARAMETER (EPS    =  1.D-10,
30205      &           DEPS   =  1.D-15)
30206
30207 C  input/output channels
30208       INTEGER LI,LO
30209       COMMON /POINOU/ LI,LO
30210 C  event debugging information
30211       INTEGER NMAXD
30212       PARAMETER (NMAXD=100)
30213       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30214      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30215       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30216      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30217 C  particle ID translation table
30218       integer         ID_pdg_list,ID_list,ID_pdg_max
30219       character*12    name_list
30220       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
30221      &                ID_pdg_max
30222 C  general particle data
30223       double precision xm_list,tau_list,gam_list,
30224      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30225      &  xm_bb82_list,xm_bb102_list
30226       integer          ich3_list,iba3_list,iq_list,
30227      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
30228       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30229      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
30230      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30231      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30232      &  ich3_list(300),iba3_list(300),iq_list(3,300),
30233      &  id_psm_list(6,6),id_vem_list(6,6),
30234      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
30235
30236       DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
30237       DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
30238      &            12212, 42212, -12212, -42212,
30239      &            8*0 /
30240       DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
30241      &            1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
30242      &            8*1.D0 /
30243
30244       DATA init /0/
30245
30246 C  initialize table
30247       if(init.eq.0) then
30248         do i=1,20
30249           if(IRPDG(i).ne.0) then
30250             IRBAM(i) = ipho_pdg2id(IRPDG(i))
30251           endif
30252         enddo
30253         init = 1
30254       endif
30255
30256 C  copy table with particles and isospin weights
30257       LISTL = 0
30258       IF(IDMOTH.EQ.22) THEN
30259         I1 = 4
30260         I2 = 8
30261       ELSE IF(IDMOTH.EQ.2212) THEN
30262         I1 = 9
30263         I2 = 10
30264       ELSE IF(IDMOTH.EQ.-2212) THEN
30265         I1 = 11
30266         I2 = 12
30267       ELSE
30268         RETURN
30269       ENDIF
30270
30271       DO 100 I=I1,I2
30272         LISTL = LISTL+1
30273         IDBAM(LISTL) = IRBAM(I)
30274         IDPDG(LISTL) = IRPDG(I)
30275         RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
30276         RGAM(LISTL)  = gam_list(iabs(IDBAM(LISTL)))
30277         RWG(LISTL)   = RWGHT(I)
30278  100  CONTINUE
30279
30280 C  debug output
30281       IF(IDEB(85).GE.20) THEN
30282         WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
30283      &    IVAL1,IVAL2
30284         DO 200 I=1,LISTL
30285           WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
30286  200    CONTINUE
30287       ENDIF
30288
30289       END
30290
30291 *$ CREATE PHO_MASSAD.FOR
30292 *COPY PHO_MASSAD
30293 CDECK  ID>, PHO_MASSAD
30294       SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30295      &                     PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30296 C***********************************************************************
30297 C
30298 C    fine-correction of low mass strings to mass of corresponding
30299 C    resonance or two particle threshold
30300 C
30301 C    input:     IFLMO         PDG ID of mother particle
30302 C               IFL1,2        requested parton flavours
30303 C                             (not used at the moment)
30304 C               PMASS         reference mass (mass of mother particle)
30305 C               XMCON         conjecture of mass
30306 C
30307 C    output:    XMOUT         output mass (adjusted input mass)
30308 C                             moved ot nearest mass possible
30309 C               IDPDG         PDG resonance ID
30310 C               IDcpc         CPC resonance ID
30311 C
30312 C**********************************************************************
30313       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30314       SAVE
30315
30316       PARAMETER ( DEPS   =  1.D-8 )
30317
30318 C  input/output channels
30319       INTEGER LI,LO
30320       COMMON /POINOU/ LI,LO
30321 C  event debugging information
30322       INTEGER NMAXD
30323       PARAMETER (NMAXD=100)
30324       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30325      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30326       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30327      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30328 C  model switches and parameters
30329       CHARACTER*8 MDLNA
30330       INTEGER ISWMDL,IPAMDL
30331       DOUBLE PRECISION PARMDL
30332       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30333 C  general particle data
30334       double precision xm_list,tau_list,gam_list,
30335      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30336      &  xm_bb82_list,xm_bb102_list
30337       integer          ich3_list,iba3_list,iq_list,
30338      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
30339       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30340      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
30341      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30342      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30343      &  ich3_list(300),iba3_list(300),iq_list(3,300),
30344      &  id_psm_list(6,6),id_vem_list(6,6),
30345      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
30346 C  particle decay data
30347       double precision wg_sec_list
30348       integer          idec_list,isec_list
30349       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30350      &  isec_list(3,500)
30351
30352       DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30353
30354       XMINP = XMCON
30355       IDPDG = 0
30356       IDcpc = 0
30357       XMOUT = XMINP
30358
30359 C  resonance treatment activated?
30360       IF(ISWMDL(23).EQ.0) RETURN
30361
30362       CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30363       IF(LISTL.LT.1) THEN
30364         IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30365      &    'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30366      &    IFLMO,IFL1,IFL2
30367         GOTO 50
30368       ENDIF
30369 C  mass small?
30370       PMASSL = (PMASS+0.15D0)**2
30371       XMINP2 = XMINP**2
30372 C  determine resonance probability
30373       DM2 = 1.1D0
30374       RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30375       IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30376 C  sample new resonance
30377         XWGSUM = 0.D0
30378         DO 100 I=1,LISTL
30379           XWG(I) = RWG(I)/RMA(I)**2
30380           XWGSUM = XWGSUM+XWG(I)
30381  100    CONTINUE
30382
30383         ITER = 0
30384  150    CONTINUE
30385         ITER = ITER+1
30386         IF(ITER.GE.5) THEN
30387           IDcpc = 0
30388           IDPDG = 0
30389           XMOUT = XMINP
30390           GOTO 50
30391         ENDIF
30392
30393         I = 0
30394         XI = XWGSUM*DT_RNDM(XMOUT)
30395  200    CONTINUE
30396           I = I+1
30397           XWGSUM = XWGSUM-XWG(I)
30398         IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30399         IDPDG = IRPDG(I)
30400         IDcpc = IRBAM(I)
30401         GARES = RGA(I)
30402         XMRES = RMA(I)
30403         XMRES2 = XMRES**2
30404 C  sample new mass (from Breit-Wigner cross section)
30405         ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30406         AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30407         XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30408         XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30409         XMOUT = SQRT(XMOUT)
30410
30411 C  check mass for decay
30412         AMDCY = 2.D0*XMRES
30413         ID = abs(IDcpc)
30414         DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30415           AMSUM = 0.D0
30416           DO 275 I=1,3
30417             IF(isec_list(I,IK).NE.0)
30418      &        AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30419  275      CONTINUE
30420           AMDCY = MIN(AMDCY,AMSUM)
30421  250    CONTINUE
30422         IF(AMDCY.GE.XMOUT) GOTO 150
30423
30424 C  debug output
30425         IF(IDEB(7).GE.10)
30426      &    WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30427      &    'PHO_MASSAD: ',
30428      &    'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30429      &    IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30430         RETURN
30431       ENDIF
30432
30433  50   CONTINUE
30434 C  debug output
30435       IF(IDEB(7).GE.15)
30436      &  WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30437      &    'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30438      &    IFLMO,IFL1,IFL2,XMCON,XMOUT
30439
30440       END
30441
30442 *$ CREATE PHO_PDF.FOR
30443 *COPY PHO_PDF
30444 CDECK  ID>, PHO_PDF
30445       SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30446 C***************************************************************
30447 C
30448 C     call different PDF sets for different particle types
30449 C
30450 C     input:      NPAR     1     IGRP(1),ISET(1)
30451 C                          2     IGRP(2),ISET(2)
30452 C                 X        momentum fraction
30453 C                 SCALE2   squared scale (GeV**2)
30454 C                 P2VIR    particle virtuality (positive, GeV**2)
30455 C
30456 C     output      PD(-6:6) field containing the x*PDF fractions
30457 C
30458 C***************************************************************
30459       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30460       SAVE
30461
30462       DIMENSION PD(-6:6)
30463
30464 C  input/output channels
30465       INTEGER LI,LO
30466       COMMON /POINOU/ LI,LO
30467 C  currently activated parton density parametrizations
30468       CHARACTER*8 PDFNAM
30469       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30470       DOUBLE PRECISION PDFLAM,PDFQ2M
30471       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30472      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30473 C  event debugging information
30474       INTEGER NMAXD
30475       PARAMETER (NMAXD=100)
30476       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30477      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30478       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30479      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30480 C  model switches and parameters
30481       CHARACTER*8 MDLNA
30482       INTEGER ISWMDL,IPAMDL
30483       DOUBLE PRECISION PARMDL
30484       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30485
30486       DIMENSION PARAM(20),VALUE(20)
30487       CHARACTER*20 PARAM
30488
30489       REAL XR,P2R,Q2R,F2GM,XPDFGM
30490       DIMENSION XPDFGM(-6:6)
30491
30492 C  check of kinematic boundaries
30493       XI = X
30494       IF(X.GT.1.D0) THEN
30495         IF(IDEB(37).GE.0) THEN
30496           WRITE(LO,'(/,1X,A,E15.8/)')
30497      &      'PHO_PDF: x>1 (corrected to x=1)',X
30498           CALL PHO_PREVNT(-1)
30499         ENDIF
30500         XI = 0.99999999999D0
30501       ELSE IF(X.LE.0.D0) THEN
30502         IF(IDEB(37).GE.0) THEN
30503           WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30504           CALL PHO_PREVNT(-1)
30505         ENDIF
30506         XI = 0.0001D0
30507       ENDIF
30508
30509       DO 100 I=-6,6
30510         PD(I) = 0.D0
30511  100  CONTINUE
30512       IRET = 1
30513
30514       IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30515
30516 C  internal PDFs
30517
30518         IF(IEXT(NPAR).EQ.0) THEN
30519           IF(ITYPE(NPAR).EQ.1) THEN
30520 C  proton PDFs
30521             IF(IGRP(NPAR).EQ.5) THEN
30522               IF(ISET(NPAR).EQ.3) THEN
30523                 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30524                 UV = UDV-DV
30525                 UDB = 2.D0*UDB
30526                 DEL = 0.D0
30527                 IRET = 0
30528               ELSE IF(ISET(NPAR).EQ.4) THEN
30529                 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30530                 UV = UDV-DV
30531                 UDB = 2.D0*UDB
30532                 DEL = 0.D0
30533                 IRET = 0
30534               ELSE IF(ISET(NPAR).EQ.5) THEN
30535                 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30536 C  heavy quarks from GRV92-HO
30537                 AMU2  = 0.3
30538                 ALAM2 = 0.248 * 0.248
30539                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30540                 SC  =  0.820
30541                 ALC =   0.98
30542                 BEC =   0.0
30543                 AKC = -0.625 - 0.523 * S
30544                 AGC =   0.0
30545                 BC  =  1.896 + 1.616 * S
30546                 DC  =   4.12 + 0.683 * S
30547                 EC  =   4.36 + 1.328 * S
30548                 ESC =  0.677 + 0.679 * S
30549                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30550                 SBO =  1.297
30551                 ALB =   0.99
30552                 BEB =   0.0
30553                 AKB =   0.0  - 0.193 * S
30554                 AGB =   0.0
30555                 BBO =   0.0
30556                 DB  =  3.447 + 0.927 * S
30557                 EB  =   4.68 + 1.259 * S
30558                 ESB =  1.892 + 2.199 * S
30559                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30560                 IRET = 0
30561               ELSE IF(ISET(NPAR).EQ.6) THEN
30562                 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30563 C  heavy quarks from GRV92-LO
30564                 AMU2  = 0.25
30565                 ALAM2 = 0.232D0**2
30566                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30567                 SC  =  0.888
30568                 ALC =   1.01
30569                 BEC =   0.37
30570                 AKC =   0.0
30571                 AGC =   0.0
30572                 BC  =   4.24 - 0.804 * S
30573                 DC  =   3.46 + 1.076 * S
30574                 EC  =   4.61 + 1.490 * S
30575                 ESC =  2.555 + 1.961 * S
30576                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30577                 SBO =  1.351
30578                 ALB =   1.00
30579                 BEB =   0.51
30580                 AKB =   0.0
30581                 AGB =   0.0
30582                 BBO =  1.848
30583                 DB  =  2.929 + 1.396 * S
30584                 EB  =   4.71 + 1.514 * S
30585                 ESB =   4.02 + 1.239 * S
30586                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30587                 IRET = 0
30588               ELSE IF(ISET(NPAR).EQ.7) THEN
30589                 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30590 C  heavy quarks from GRV92-HO
30591                 AMU2  = 0.3
30592                 ALAM2 = 0.248 * 0.248
30593                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30594                 SC  =  0.820
30595                 ALC =   0.98
30596                 BEC =   0.0
30597                 AKC = -0.625 - 0.523 * S
30598                 AGC =   0.0
30599                 BC  =  1.896 + 1.616 * S
30600                 DC  =   4.12 + 0.683 * S
30601                 EC  =   4.36 + 1.328 * S
30602                 ESC =  0.677 + 0.679 * S
30603                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30604                 SBO =  1.297
30605                 ALB =   0.99
30606                 BEB =   0.0
30607                 AKB =   0.0  - 0.193 * S
30608                 AGB =   0.0
30609                 BBO =   0.0
30610                 DB  =  3.447 + 0.927 * S
30611                 EB  =   4.68 + 1.259 * S
30612                 ESB =  1.892 + 2.199 * S
30613                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30614                 IRET = 0
30615               ELSE IF(ISET(NPAR).EQ.8) THEN
30616                 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30617                 DEL = DS-US
30618                 UDB = DS+US
30619 C  heavy quarks from GRV92-LO
30620                 AMU2  = 0.25
30621                 ALAM2 = 0.232D0**2
30622                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30623                 SC  =  0.888
30624                 ALC =   1.01
30625                 BEC =   0.37
30626                 AKC =   0.0
30627                 AGC =   0.0
30628                 BC  =   4.24 - 0.804 * S
30629                 DC  =   3.46 + 1.076 * S
30630                 EC  =   4.61 + 1.490 * S
30631                 ESC =  2.555 + 1.961 * S
30632                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30633                 SBO =  1.351
30634                 ALB =   1.00
30635                 BEB =   0.51
30636                 AKB =   0.0
30637                 AGB =   0.0
30638                 BBO =  1.848
30639                 DB  =  2.929 + 1.396 * S
30640                 EB  =   4.71 + 1.514 * S
30641                 ESB =   4.02 + 1.239 * S
30642                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30643                 IRET = 0
30644               ELSE IF(ISET(NPAR).EQ.9) THEN
30645 *               CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30646                 DEL = DS-US
30647                 UDB = DS+US
30648 C  heavy quarks from GRV92-LO
30649                 AMU2  = 0.25
30650                 ALAM2 = 0.232D0**2
30651                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30652                 SC  =  0.888
30653                 ALC =   1.01
30654                 BEC =   0.37
30655                 AKC =   0.0
30656                 AGC =   0.0
30657                 BC  =   4.24 - 0.804 * S
30658                 DC  =   3.46 + 1.076 * S
30659                 EC  =   4.61 + 1.490 * S
30660                 ESC =  2.555 + 1.961 * S
30661                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30662                 SBO =  1.351
30663                 ALB =   1.00
30664                 BEB =   0.51
30665                 AKB =   0.0
30666                 AGB =   0.0
30667                 BBO =  1.848
30668                 DB  =  2.929 + 1.396 * S
30669                 EB  =   4.71 + 1.514 * S
30670                 ESB =   4.02 + 1.239 * S
30671                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30672                 IRET = 0
30673               ENDIF
30674               PD(-5) = BB
30675               PD(-4) = CB
30676               PD(-3) = SB
30677               PD(-2) = 0.5D0*(UDB-DEL)
30678               PD(-1) = 0.5D0*(UDB+DEL)
30679               PD(0)  = GL
30680               PD(1)  = DV+PD(-1)
30681               PD(2)  = UV+PD(-2)
30682               PD(3)  = PD(-3)
30683               PD(4)  = PD(-4)
30684               PD(5)  = PD(-5)
30685             ENDIF
30686           ELSE IF(ITYPE(NPAR).EQ.2) THEN
30687 C  pion PDFs (default for pi+)
30688             IF(IGRP(NPAR).EQ.5) THEN
30689               IF(ISET(NPAR).EQ.1) THEN
30690                 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30691                 IRET = 0
30692               ELSE IF(ISET(NPAR).EQ.2) THEN
30693                 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30694                 IRET = 0
30695               ENDIF
30696               PD(-5) = BB
30697               PD(-4) = CB
30698               PD(-3) = QB
30699               PD(-2) = QB
30700               PD(-1) = QB+VA
30701               PD(0)  = GL
30702               PD(1)  = QB
30703               PD(2)  = VA+QB
30704               PD(3)  = QB
30705               PD(4)  = CB
30706               PD(5)  = BB
30707             ENDIF
30708           ELSE IF(ITYPE(NPAR).EQ.3) THEN
30709 C  photon PDFs
30710             IF(IGRP(NPAR).EQ.5) THEN
30711               IF(ISET(NPAR).EQ.1) THEN
30712                 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30713                 IRET = 0
30714               ELSE IF(ISET(NPAR).EQ.2) THEN
30715                 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30716                 IRET = 0
30717               ELSE IF(ISET(NPAR).EQ.3) THEN
30718                 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30719                 IRET = 0
30720               ENDIF
30721 C  reweight with Drees-Godbole factor
30722               WGX = 1.D0
30723               IF(P2VIR.GT.0.001D0) THEN
30724                 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30725      &               /LOG(SCALE2/PARMDL(144))
30726                 WGX = MAX(WGX,0.D0)
30727               ENDIF
30728               PD(-5) = BB*WGX/137.D0
30729               PD(-4) = CB*WGX/137.D0
30730               PD(-3) = SB*WGX/137.D0
30731               PD(-2) = UB*WGX/137.D0
30732               PD(-1) = DB*WGX/137.D0
30733               PD(0)  = GL*WGX*WGX/137.D0
30734               PD(1)  = PD(-1)
30735               PD(2)  = PD(-2)
30736               PD(3)  = PD(-3)
30737               PD(4)  = PD(-4)
30738               PD(5)  = PD(-5)
30739             ELSE IF(IGRP(NPAR).EQ.8) THEN
30740               IF(ISET(NPAR).EQ.1) THEN
30741                 CALL PHO_PHGAL (XI,SCALE2,PD)
30742                 IRET = 0
30743               ENDIF
30744             ENDIF
30745           ELSE IF(ITYPE(NPAR).EQ.20) THEN
30746 C  Pomeron PDFs
30747             MODE = IGRP(NPAR)
30748             IF(MODE.EQ.1) THEN
30749               PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30750               IRET = 0
30751             ELSE IF(MODE.EQ.2) THEN
30752               PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30753               IRET = 0
30754             ELSE IF(MODE.EQ.3) THEN
30755               PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30756               IRET = 0
30757             ELSE IF(MODE.EQ.4) THEN
30758               CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30759               DO 105 I=-4,4
30760                 PD(I) = PD(I)*PARMDL(78)
30761  105          CONTINUE
30762               IRET = 0
30763             ENDIF
30764           ENDIF
30765
30766 C  external PDFs
30767
30768         ELSE IF(IEXT(NPAR).EQ.2) THEN
30769 C  PDFLIB call: new PDF numbering
30770           IF(NPAR.NE.NPAOLD) THEN
30771             PARAM(1) = 'NPTYPE'
30772             PARAM(2) = 'NGROUP'
30773             PARAM(3) = 'NSET'
30774             PARAM(4) = ' '
30775             VALUE(1) = ITYPE(NPAR)
30776             VALUE(2) = ABS(IGRP(NPAR))
30777             VALUE(3) = ISET(NPAR)
30778             CALL PDFSET(PARAM,VALUE)
30779           ENDIF
30780           IF(ITYPE(NPAR).EQ.3) THEN
30781             IP2 = 0
30782             CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30783      &                   PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30784           ELSE
30785             SCALE = SQRT(SCALE2)
30786             CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30787      &                   PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30788           ENDIF
30789           DO 115 I=3,6
30790             PD(I) = PD(-I)
30791  115      CONTINUE
30792           IF(ITYPE(NPAR).EQ.1) THEN
30793 C  proton valence quarks
30794             PD(1) = PD(1)+PD(-1)
30795             PD(2) = PD(2)+PD(-2)
30796           ELSE IF(ITYPE(NPAR).EQ.2) THEN
30797 C  pi+ valences
30798             DVAL = PD(1)
30799             PD(1) = PD(-1)
30800             PD(-1) = DVAL+PD(1)
30801             PD(2) = PD(2)+PD(-2)
30802           ELSE IF(ITYPE(NPAR).EQ.3) THEN
30803 C  photon conventions
30804             PD(1) = PD(-1)
30805             PD(2) = PD(-2)
30806           ENDIF
30807           IRET = 0
30808
30809         ELSE IF(IEXT(NPAR).EQ.3) THEN
30810 C  PHOLIB call: version 2.0
30811           CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30812           IF(IRET.LT.0) THEN
30813             WRITE(LO,'(/1X,A,I2)')
30814      &        'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30815             CALL PHO_ABORT
30816           ENDIF
30817           IRET = 0
30818
30819 C  photon PDFs depending on photon virtuality
30820
30821         ELSE IF(IEXT(NPAR).EQ.4) THEN
30822           IF(IGRP(NPAR).EQ.1) THEN
30823 C  Schuler/Sjostrand PDF (interface to single precision)
30824             XR = XI
30825             Q2R = SCALE2
30826             P2R = P2VIR
30827             IP2 = 0
30828             CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30829             DO 120 I=-6,6
30830               PD(I) = DBLE(XPDFGM(I))
30831  120        CONTINUE
30832             IRET = 0
30833           ELSE IF(IGRP(NPAR).EQ.5) THEN
30834 C  Gluck/Reya/Stratmann
30835             IF(ISET(NPAR).EQ.4) THEN
30836               CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30837               CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30838               IRET = 0
30839               PD(-5) = 0.D0
30840               PD(-4) = CB
30841               PD(-3) = SB/137.D0
30842               PD(-2) = UB/137.D0
30843               PD(-1) = DB/137.D0
30844               PD(0)  = GL/137.D0
30845               PD(1)  = PD(-1)
30846               PD(1)  = PD(-1)
30847               PD(2)  = PD(-2)
30848               PD(3)  = PD(-3)
30849               PD(4)  = PD(-4)
30850               PD(5)  = PD(-5)
30851             ENDIF
30852           ENDIF
30853         ENDIF
30854
30855 C  check for errors
30856
30857         IF(IRET.NE.0) THEN
30858           WRITE(LO,'(/1X,A,/10X,5I6)')
30859      &      'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30860      &      NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30861           CALL PHO_ABORT
30862         ENDIF
30863 C  error in NPAR
30864       ELSE
30865         WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30866         CALL PHO_ABORT
30867       ENDIF
30868       NPAOLD = NPAR
30869
30870 C  valence quark treatment
30871
30872       IF(ITYPE(NPAR).EQ.2) THEN
30873 C  meson conventions
30874         IF(IPARID(NPAR).EQ.111) THEN
30875 C  pi0 valence quarks
30876           PD(-1) = (PD(1)+PD(-1))/2.D0
30877           PD(1)  = PD(-1)
30878           PD(-2) = (PD(2)+PD(-2))/2.D0
30879           PD(2)  = PD(-2)
30880         ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30881 C  K+/-
30882           VALS = PD(-1)-PD(1)
30883           PD(-1) = PD(1)
30884           PD(-3) = PD(-3)+VALS
30885         ELSE IF(    (IPARID(NPAR).EQ.311)
30886      &          .OR.(IPARID(NPAR).EQ.310)
30887      &          .OR.(IPARID(NPAR).EQ.130)) THEN
30888 C  neutral kaons
30889           VALS = PD(-1)-PD(1)
30890           VALU = PD(2)-PD(-2)
30891           PD(-1) = PD(1)
30892           PD(2) = PD(-2)
30893           PD(2)  = PD(2)+VALU/2.D0
30894           PD(-2) = PD(-2)+VALU/2.D0
30895           PD(3)  = PD(3)+VALS/2.D0
30896           PD(-3) = PD(-3)+VALS/2.D0
30897         ENDIF
30898       ELSE IF(ITYPE(NPAR).EQ.1) THEN
30899 C  nucleon conventions
30900         IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30901 C  neutron valence quarks
30902           DUM = PD(1)
30903           PD(1) = PD(2)
30904           PD(2) = DUM
30905         ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30906 C  (anti-)sigma+
30907           VALS = PD(1)-PD(-1)
30908           PD(1) = PD(-1)
30909           PD(3) = PD(3)+VALS
30910         ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30911 C  (anti-)sigma-
30912           VALS = PD(1)-PD(-1)
30913           VALD = PD(2)-PD(-2)
30914           PD(1) = PD(-1)
30915           PD(2) = PD(-2)
30916           PD(1) = PD(1)+VALD
30917           PD(3) = PD(3)+VALS
30918         ELSE IF(    (ABS(IPARID(NPAR)).EQ.3122)
30919      &          .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30920 C  (anti-)sigma0 and (anti-)lambda
30921           VALS = PD(1)-PD(-1)
30922           VALD = (PD(2)-PD(-2))/2.D0
30923           PD(1) = PD(-1)
30924           PD(2) = PD(-2)
30925           PD(1) = PD(1)+VALD
30926           PD(2) = PD(2)+VALD
30927           PD(3) = PD(3)+VALS
30928         ENDIF
30929       ENDIF
30930
30931 C  antiparticle
30932       IF(IPARID(NPAR).LT.0) THEN
30933         DO 190 I=1,4
30934           DUM=PD(I)
30935           PD(I)=PD(-I)
30936           PD(-I)=DUM
30937  190    CONTINUE
30938       ENDIF
30939
30940 C  optionally remove valence quarks
30941       IF(IPAVA(NPAR).EQ.0) THEN
30942         DO 200 I=1,4
30943           PD(I) = MIN(PD(-I),PD(I))
30944           PD(-I) = PD(I)
30945  200    CONTINUE
30946       ENDIF
30947
30948 C  debug information
30949       IF(IDEB(37).GE.30) WRITE(LO,
30950      &  '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30951      &  'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30952      &  NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30953      &  'PD(0)     ',PD(0),'PD(1..6)  ',(PD(I),I=1,6)
30954
30955       END
30956
30957 *$ CREATE PHO_QPMPDF.FOR
30958 *COPY PHO_QPMPDF
30959 CDECK  ID>, PHO_QPMPDF
30960       SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30961 C***************************************************************
30962 C
30963 C     contribution to photon PDF from box graph
30964 C     (Bethe-Heitler process)
30965 C
30966 C     input:      IQ       quark flavour
30967 C                 SCALE2   scale (GeV**2, positive)
30968 C                 PTREF    reference scale (GeV, positive)
30969 C                 X        parton momentum fraction
30970 C                 PVIRT    photon virtuality (GeV**2, positive)
30971 C                 FXP      x*f(x,Q**2), x times parton density
30972 C
30973 C***************************************************************
30974       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30975       SAVE
30976
30977 C  input/output channels
30978       INTEGER LI,LO
30979       COMMON /POINOU/ LI,LO
30980 C  event debugging information
30981       INTEGER NMAXD
30982       PARAMETER (NMAXD=100)
30983       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30984      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30985       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30986      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30987 C  internal rejection counters
30988       INTEGER NMXJ
30989       PARAMETER (NMXJ=60)
30990       CHARACTER*10 REJTIT
30991       INTEGER IFAIL
30992       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30993 C  some constants
30994       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30995       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30996      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30997
30998       DIMENSION QM(6)
30999       DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
31000
31001       FXP = 0.D0
31002       I = ABS(IQ)
31003 C
31004 *     QM2 = MAX(QM(I),PTREF)**2
31005 *     QM2 = MAX(QM2,PVIRT)
31006 *     BBE = (1.D0-X)*SCALE2
31007 *     IF(BBE.LE.0.D0) THEN
31008 *       IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
31009 *    &    'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
31010 *    &    PVIRT,QM(I)
31011 *     ENDIF
31012 *     FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
31013 *    &  *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
31014 C  Bethe-Heitler process approximation for 2*x*p2/q2 << 1
31015       QM2 = MAX(QM(I),PTREF)**2
31016       W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
31017       IF(W2.GT.4.D0*QM2) THEN
31018         BE = SQRT(1.D0-4.D0*QM2/W2)
31019         BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
31020         BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
31021 *       FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
31022         FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
31023      &         +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
31024      &         -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
31025      &         +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
31026      &         -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
31027       ELSE
31028         IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
31029      &    'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
31030      &    PVIRT,QM(I)
31031       ENDIF
31032 C  debug output
31033       IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
31034      &  'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
31035       END
31036
31037 *$ CREATE PHO_SETPDF.FOR
31038 *COPY PHO_SETPDF
31039 CDECK  ID>, PHO_SETPDF
31040       SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
31041 C***************************************************************
31042 C
31043 C     assigns  PDF numbers to particles
31044 C
31045 C     input:      IDPDG    PDG number of particle
31046 C                 ITYP     particle type
31047 C                 IPAR     PDF paramertization
31048 C                 ISET     number of set
31049 C                 IEXT     library number for PDF calculation
31050 C                 IPAVAL   (only output)
31051 C                          1 PDF with valence quarks
31052 C                          0 PDF without valence quarks
31053 C                 MODE     -1   add entry to table
31054 C                           1   read from table
31055 C                           2   output of table
31056 C
31057 C***************************************************************
31058       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31059       SAVE
31060
31061 C  input/output channels
31062       INTEGER LI,LO
31063       COMMON /POINOU/ LI,LO
31064 C  event debugging information
31065       INTEGER NMAXD
31066       PARAMETER (NMAXD=100)
31067       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31068      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31069       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31070      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31071 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
31072       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
31073       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
31074       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
31075      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
31076
31077       DIMENSION IPDFS(5,50)
31078       DATA IENTRY / 0 /
31079
31080       IF(MODE.EQ.1) THEN
31081         I = 1
31082         IF(IDPDG.EQ.81) THEN
31083           IDCMP = IDEQP(1)
31084           IPAVAL = IHFLS(1)
31085         ELSE IF(IDPDG.EQ.82) THEN
31086           IDCMP = IDEQP(2)
31087           IPAVAL = IHFLS(2)
31088         ELSE
31089           IDCMP = IDPDG
31090           IPAVAL = 1
31091         ENDIF
31092 200     CONTINUE
31093           IF(IDCMP.EQ.IPDFS(1,I)) THEN
31094             ITYP = IPDFS(2,I)
31095             IPAR = IPDFS(3,I)
31096             ISET = IPDFS(4,I)
31097             IEXT = IPDFS(5,I)
31098             IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
31099      &        'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
31100             RETURN
31101           ENDIF
31102           I = I+1
31103           IF(I.GT.IENTRY) THEN
31104             WRITE(LO,'(/1X,A,I7)')
31105      &        'PHO_SETPDF: no PDF assigned to ',IDCMP
31106             CALL PHO_ABORT
31107           ENDIF
31108         GOTO 200
31109       ELSE IF(MODE.EQ.-1) THEN
31110         DO 50 I=1,IENTRY
31111           IF(IDPDG.EQ.IPDFS(1,I)) THEN
31112             WRITE(LO,'(/1X,A,5I6)')
31113      &        'PHO_SETPDF: overwrite old particle PDF',
31114      &        IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
31115             GOTO 100
31116           ENDIF
31117  50     CONTINUE
31118         I = IENTRY+1
31119         IF(I.GT.50) THEN
31120           WRITE(LO,'(/1X,A,/1x,6I6)')
31121      &      'PHO_SETPDF:ERROR: no space left in IPDFS:',
31122      &      I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
31123           STOP
31124         ENDIF
31125         IENTRY = I
31126  100    CONTINUE
31127         IPDFS(1,I) = IDPDG
31128         IF(IDPDG.EQ.990) THEN
31129           ITYP1 = 20
31130         ELSE IF(IDPDG.EQ.22) THEN
31131           ITYP1 = 3
31132         ELSE IF(ABS(IDPDG).LT.1000) THEN
31133           ITYP1 = 2
31134         ELSE
31135           ITYP1 = 1
31136         ENDIF
31137         IPDFS(2,I) = ITYP1
31138         IPDFS(3,I) = IPAR
31139         IPDFS(4,I) = ISET
31140         IPDFS(5,I) = IEXT
31141       ELSE IF(MODE.EQ.-2) THEN
31142         WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
31143         DO 150 I=1,IENTRY
31144           WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,'  particle:',IPDFS(1,I),
31145      &      '   PDF-set  ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
31146  150    CONTINUE
31147       ELSE
31148         WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
31149       ENDIF
31150       END
31151
31152 *$ CREATE PHO_GETPDF.FOR
31153 *COPY PHO_GETPDF
31154 CDECK  ID>, PHO_GETPDF
31155       SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31156 C***************************************************************
31157 C
31158 C     get PDF information
31159 C
31160 C     input:      NPAR     1  first PDF in /POPPDF/
31161 C                          2  second PDF in /POPPDF/
31162 C
31163 C     output:     PDFNA    name of PDf parametrization
31164 C                 ALA      QCD LAMBDA (4 flavours, in GeV)
31165 C                 Q2MI     minimal Q2
31166 C                 Q2MA     maximal Q2
31167 C                 XMI      minimal X
31168 C                 XMA      maximal X
31169 C
31170 C***************************************************************
31171       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31172       SAVE
31173
31174       CHARACTER*8 PDFNA
31175
31176 C  input/output channels
31177       INTEGER LI,LO
31178       COMMON /POINOU/ LI,LO
31179
31180 C  PHOLIB 4.15 common
31181       COMMON /W50512/ QCDL4,QCDL5
31182       COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
31183
31184 C  PHOPDF version 2.0 common
31185       PARAMETER (MAXS=6,MAXP=10)
31186       CHARACTER*4 CHPAR
31187       COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
31188      & NSET(MAXP,2),NFL(MAXP)
31189       COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
31190
31191 C  currently activated parton density parametrizations
31192       CHARACTER*8 PDFNAM
31193       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31194       DOUBLE PRECISION PDFLAM,PDFQ2M
31195       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31196      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31197
31198       DIMENSION PARAM(20),VALUE(20)
31199       CHARACTER*20 PARAM
31200
31201       IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
31202         WRITE(LO,'(/1X,A,I6)')
31203      &    'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
31204         CALL PHO_ABORT
31205       ENDIF
31206       ALA = 0.D0
31207
31208       IF(IEXT(NPAR).EQ.0) THEN
31209
31210 C  internal parametrizations
31211
31212         IF(ITYPE(NPAR).EQ.1) THEN
31213 C  proton PDFs
31214           IF(IGRP(NPAR).EQ.5) THEN
31215             IF(ISET(NPAR).EQ.3) THEN
31216               ALA    = 0.2D0
31217               Q2MI   = 0.3D0
31218               PDFNA  = 'GRV92 HO'
31219             ELSE IF(ISET(NPAR).EQ.4) THEN
31220               ALA    = 0.2D0
31221               Q2MI   = 0.25D0
31222               PDFNA  = 'GRV92 LO'
31223             ELSE IF(ISET(NPAR).EQ.5) THEN
31224               ALA    = 0.2D0
31225               Q2MI   = 0.4D0
31226               PDFNA  = 'GRV94 HO'
31227             ELSE IF(ISET(NPAR).EQ.6) THEN
31228               ALA    = 0.2D0
31229               Q2MI   = 0.4D0
31230               PDFNA  = 'GRV94 LO'
31231             ELSE IF(ISET(NPAR).EQ.7) THEN
31232               ALA    = 0.2D0
31233               Q2MI   = 0.4D0
31234               PDFNA  = 'GRV94 DI'
31235             ELSE IF(ISET(NPAR).EQ.8) THEN
31236               ALA    = 0.175D0
31237               Q2MI   = 0.8D0
31238               PDFNA  = 'GRV98 LO'
31239             ELSE IF(ISET(NPAR).EQ.9) THEN
31240               ALA    = 0.175D0
31241               Q2MI   = 0.8D0
31242               PDFNA  = 'GRV98 SC'
31243             ENDIF
31244           ENDIF
31245         ELSE IF(ITYPE(NPAR).EQ.2) THEN
31246 C  pion PDFs
31247           IF(IGRP(NPAR).EQ.5) THEN
31248             IF(ISET(NPAR).EQ.1) THEN
31249               ALA    = 0.2D0
31250               Q2MI   = 0.3D0
31251               PDFNA  = 'GRV-P HO'
31252             ELSE IF(ISET(NPAR).EQ.2) THEN
31253               ALA    = 0.2D0
31254               Q2MI   = 0.25D0
31255               PDFNA  = 'GRV-P LO'
31256             ENDIF
31257           ENDIF
31258         ELSE IF(ITYPE(NPAR).EQ.3) THEN
31259 C  photon PDFs
31260           IF(IGRP(NPAR).EQ.5) THEN
31261             IF(ISET(NPAR).EQ.1) THEN
31262               ALA    = 0.2D0
31263               Q2MI   = 0.3D0
31264               PDFNA  = 'GRV-G LH'
31265             ELSE IF(ISET(NPAR).EQ.2) THEN
31266               ALA    = 0.2D0
31267               Q2MI   = 0.3D0
31268               PDFNA  = 'GRV-G HO'
31269             ELSE IF(ISET(NPAR).EQ.3) THEN
31270               ALA    = 0.2D0
31271               Q2MI   = 0.25D0
31272               PDFNA  = 'GRV-G LO'
31273             ENDIF
31274           ELSE IF(IGRP(NPAR).EQ.8) THEN
31275             IF(ISET(NPAR).EQ.1) THEN
31276               ALA    = 0.2D0
31277               Q2MI   = 4.D0
31278               PDFNA  = 'AGL-G LO'
31279             ENDIF
31280           ENDIF
31281         ELSE IF(ITYPE(NPAR).EQ.20) THEN
31282 C  pomeron PDFs
31283           IF(IGRP(NPAR).EQ.4) THEN
31284             CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
31285           ELSE
31286             ALA    = 0.3D0
31287             Q2MI   = 2.D0
31288             PDFNA  = 'POM-PDF1'
31289           ENDIF
31290         ENDIF
31291
31292 C  external parametrizations
31293
31294       ELSE IF(IEXT(NPAR).EQ.1) THEN
31295 C  PDFLIB call: old numbering
31296         PARAM(1) = 'MODE'
31297         PARAM(2) = ' '
31298         VALUE(1) = IGRP(NPAR)
31299         CALL PDFSET(PARAM,VALUE)
31300         Q2MI = Q2MIN
31301         Q2MA = Q2MAX
31302         XMI  = XMIN
31303         XMA  = XMAX
31304         ALA  = QCDL4
31305         PDFNA = 'PDFLIB1'
31306       ELSE IF(IEXT(NPAR).EQ.2) THEN
31307 C  PDFLIB call: new numbering
31308         PARAM(1) = 'NPTYPE'
31309         PARAM(2) = 'NGROUP'
31310         PARAM(3) = 'NSET'
31311         PARAM(4) = ' '
31312         VALUE(1) = ITYPE(NPAR)
31313         VALUE(2) = IGRP(NPAR)
31314         VALUE(3) = ISET(NPAR)
31315         CALL PDFSET(PARAM,VALUE)
31316         Q2MI = Q2MIN
31317         Q2MA = Q2MAX
31318         XMI  = XMIN
31319         XMA  = XMAX
31320         ALA  = QCDL4
31321         PDFNA = 'PDFLIB2'
31322       ELSE IF(IEXT(NPAR).EQ.3) THEN
31323 C  PHOLIB interface
31324         ALA  = ALM(IGRP(NPAR),ISET(NPAR))
31325         Q2MI = 2.D0
31326         PDFNA = CHPAR(IGRP(NPAR))
31327
31328 C  some special internal parametrizations
31329
31330       ELSE IF(IEXT(NPAR).EQ.4) THEN
31331 C  photon PDFs depending on virtualities
31332         IF(IGRP(NPAR).EQ.1) THEN
31333 C  Schuler/Sjostrand parametrization
31334           ALA = 0.2D0
31335           IF(ISET(NPAR).EQ.1) THEN
31336             Q2MI = 0.2D0
31337             PDFNA = 'SaS-1D  '
31338           ELSE IF(ISET(NPAR).EQ.2) THEN
31339             Q2MI = 0.2D0
31340             PDFNA = 'SaS-1M  '
31341           ELSE IF(ISET(NPAR).EQ.3) THEN
31342             Q2MI = 2.D0
31343             PDFNA = 'SaS-2D  '
31344           ELSE IF(ISET(NPAR).EQ.4) THEN
31345             Q2MI = 2.D0
31346             PDFNA = 'SaS-2M  '
31347           ENDIF
31348         ELSE IF(IGRP(NPAR).EQ.5) THEN
31349 C  Gluck/Reya/Stratmann parametrization
31350           IF(ISET(NPAR).EQ.4) THEN
31351             ALA = 0.2D0
31352             Q2MI = 0.6D0
31353             PDFNA = 'GRS-G LO'
31354           ENDIF
31355         ENDIF
31356       ELSE IF(IEXT(NPAR).EQ.5) THEN
31357 C  Schuler/Sjostrand anomalous only
31358         ALA   = 0.2D0
31359         Q2MI  = 0.2D0
31360         PDFNA = 'SaS anom'
31361       ENDIF
31362       IF(ALA.LT.0.01D0) THEN
31363         WRITE(LO,'(/1X,2A,/10X,5I6)')
31364      &    'PHO_GETPDF:ERROR: ',
31365      &    'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31366      &    NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31367         CALL PHO_ABORT
31368       ENDIF
31369
31370       END
31371
31372 *$ CREATE PHO_ACTPDF.FOR
31373 *COPY PHO_ACTPDF
31374 CDECK  ID>, PHO_ACTPDF
31375       SUBROUTINE PHO_ACTPDF(IDPDG,K)
31376 C***************************************************************
31377 C
31378 C     activate PDF for QCD calculations
31379 C
31380 C     input:      IDPDG    PDG particle number
31381 C                 K        1  first PDF in /POPPDF/
31382 C                          2  second PDF in /POPPDF/
31383 C                         -2  write current settings
31384 C
31385 C     output:     /POPPDF/
31386 C
31387 C***************************************************************
31388       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31389       SAVE
31390
31391 C  input/output channels
31392       INTEGER LI,LO
31393       COMMON /POINOU/ LI,LO
31394 C  event debugging information
31395       INTEGER NMAXD
31396       PARAMETER (NMAXD=100)
31397       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31398      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31399       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31400      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31401 C  currently activated parton density parametrizations
31402       CHARACTER*8 PDFNAM
31403       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31404       DOUBLE PRECISION PDFLAM,PDFQ2M
31405       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31406      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31407
31408       IF(K.GT.0) THEN
31409
31410 C  read PDF from table
31411         CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31412      &                 IPAVA(K),1)
31413         IPARID(K) = IDPDG
31414 C  get PDF parameters
31415         CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31416 C  initialize alpha_s calculation
31417         alam2 = PDFLAM(K)*PDFLAM(K)
31418         DUMMY = PHO_ALPHAS(alam2,-K)
31419
31420         IF(IDEB(2).GE.20) THEN
31421           WRITE(LO,'(1X,A)')
31422      &      'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31423           WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31424      &      PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31425      &      IEXT(K),IPARID(K)
31426         ENDIF
31427         NPAOLD = K
31428
31429       ELSE IF(K.EQ.-2) THEN
31430
31431 C  write table of current PDFs
31432         WRITE(LO,'(1X,A)')
31433      &    'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31434         WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31435      &    PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31436      &    IPARID(1)
31437         WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31438      &    PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31439      &    IPARID(2)
31440
31441       ELSE
31442
31443         WRITE(LO,'(/1X,A,2I4)')
31444      &    'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31445         CALL PHO_ABORT
31446
31447       ENDIF
31448
31449       END
31450
31451 *$ CREATE PHO_PDFTST.FOR
31452 *COPY PHO_PDFTST
31453 CDECK  ID>, PHO_PDFTST
31454       SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31455 C*********************************************************************
31456 C
31457 C     structure function test utility
31458 C
31459 C     input:    IDPDG    PDG ID of particle
31460 C               SCALE2   squared scale (GeV**2)
31461 C               P2MASS   particle virtuality (pos, GeV**2)
31462 C
31463 C     output:   tables of PDF, sum rule checking, table of F2
31464 C
31465 C*********************************************************************
31466       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31467       SAVE
31468
31469 C  input/output channels
31470       INTEGER LI,LO
31471       COMMON /POINOU/ LI,LO
31472 C  currently activated parton density parametrizations
31473       CHARACTER*8 PDFNAM
31474       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31475       DOUBLE PRECISION PDFLAM,PDFQ2M
31476       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31477      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31478 C  some constants
31479       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31480       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31481      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31482
31483       DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31484       CHARACTER*8 PDFNA
31485
31486       CALL PHO_ACTPDF(IDPDG,1)
31487       CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31488
31489       WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31490       WRITE(LO,'(A)') ' ======================================='
31491
31492       WRITE(LO,'(/,A,3I10)')
31493      &  ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31494       WRITE(LO,'(A,A)')     ' corresponds to ',PDFNA
31495       WRITE(LO,'(A,E12.3)') '  used squared scale (GeV**2):',SCALE2
31496       WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31497       WRITE(LO,'(/1X,A)') 'x times parton densities'
31498       WRITE(LO,'(1X,A)') '    X         PD(-4 - 4)'
31499       WRITE(LO,'(1X,A)')
31500      &   ' ============================================================'
31501
31502 C  logarithmic loop over x values
31503 C  upper bound
31504       XUPPER=0.9999D0
31505 C  lower bound
31506       XLOWER=1.D-4
31507 C  number of steps
31508       NSTEP=50
31509
31510       XFIRST=LOG(XLOWER)
31511       XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31512       DO 100 I=1,NSTEP
31513         X=EXP(XFIRST)
31514         XCONTR=X
31515         CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31516         IF(X.NE.XCONTR) THEN
31517           WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31518         ENDIF
31519         WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31520         XFIRST=XFIRST+XDELTA
31521  100  CONTINUE
31522
31523       IF(IDPDG.EQ.22) THEN
31524         WRITE(LO,'(/1X,A)')
31525      &   'comparison PDF to contribution due to box diagram'
31526         WRITE(LO,'(1X,A)') '    X   PD(1),PB(1), .... ,PD(4),PB(4)'
31527         WRITE(LO,'(1X,A)')
31528      &   ' ============================================================'
31529         XFIRST=LOG(XLOWER)
31530         XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31531         DO 110 I=1,NSTEP
31532           X=EXP(XFIRST)
31533           CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31534           DO 120 K=1,4
31535             CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31536  120      CONTINUE
31537           WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31538           XFIRST=XFIRST+XDELTA
31539  110    CONTINUE
31540       ENDIF
31541
31542 C  check momentum sum rule
31543
31544       WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31545       DO 199 I=-6,6
31546         PDSUM(I) = 0.D0
31547         PDAVE(I) = 0.D0
31548  199  CONTINUE
31549       ITER=5000
31550       DO 200 I=1,ITER
31551         XX=DBLE(I)/DBLE(ITER)
31552         IF(XX.EQ.1.D0) XX = 0.999999D0
31553         CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31554         DO 202 K=-6,6
31555           PDSUM(K) = PDSUM(K)+PD(K)/XX
31556           PDAVE(K) = PDAVE(K)+PD(K)
31557  202    CONTINUE
31558  200  CONTINUE
31559       WRITE(LO,'(1X,A)')
31560      &  'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31561       XSUM = 0.D0
31562       DO 204 I=-6,6
31563         PDSUM(I) = PDSUM(I)/DBLE(ITER)
31564         PDAVE(I) = PDAVE(I)/DBLE(ITER)
31565         XSUM = XSUM+PDAVE(I)
31566         WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31567  204  CONTINUE
31568       WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31569       DO 205 I=1,6
31570         WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31571  205  CONTINUE
31572       WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31573       WRITE(LO,'(A/)') ' ============================================='
31574
31575 C  table of F2
31576
31577       WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31578      &  'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31579      &  '-----------------------------------------------------'
31580       ITER=100
31581       DO 300 I=1,ITER
31582         XX=DBLE(I)/DBLE(ITER)
31583         IF(XX.EQ.1.D0) XX = 0.9999D0
31584         CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31585         F2 = 0.D0
31586         DO 302 K=-6,6
31587           IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31588  302    CONTINUE
31589         WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31590  300  CONTINUE
31591       WRITE(LO,'(A/)') ' ============================================='
31592       END
31593
31594 *$ CREATE PHO_REGPAR.FOR
31595 *COPY PHO_REGPAR
31596 CDECK  ID>, PHO_REGPAR
31597       SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31598      &                  IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31599 C**********************************************************************
31600 C
31601 C     registration of particle in /POEVT1/ and /POEVT2/
31602 C
31603 C     input:    ISTH             status code of particle
31604 C                                 -2     initial parton hard scattering
31605 C                                 -1     parton
31606 C                                  0     string
31607 C                                  1     visible particle (no color)
31608 C                                  2     decayed particle
31609 C               IDPDG            PDG particle ID code
31610 C               IDBAM            CPC particle ID code
31611 C               JM1,JM2          first and second mother index
31612 C               P1..P4           four momentum
31613 C               IPHIS1           extended history information
31614 C                                  IPHIS1<100: JM1 from particle 1
31615 C                                  IPHIS1>100: JM1 from particle 2
31616 C                                  1    valence quark
31617 C                                  2    valence diquark
31618 C                                  3    sea quark
31619 C                                  4    sea diquark
31620 C                                  (neg. for antipartons)
31621 C               IPHIS2           extended history information
31622 C                                  positive: JM2 from particle 1
31623 C                                  negative: JM2 from particle 2
31624 C                                  (see IPHIS1)
31625 C               IC1,IC2          color labels for partons
31626 C               IMODE            1  register given parton
31627 C                                0  reset /POEVT1/ and /POEVT2/
31628 C                                2  return data of entry IPOS
31629 C
31630 C               IPOS             position of particle in /POEVT1/
31631 C
31632 C**********************************************************************
31633       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31634       SAVE
31635
31636       PARAMETER (DEPS = 1.D-20)
31637
31638 C  input/output channels
31639       INTEGER LI,LO
31640       COMMON /POINOU/ LI,LO
31641 C  event debugging information
31642       INTEGER NMAXD
31643       PARAMETER (NMAXD=100)
31644       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31645      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31646       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31647      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31648
31649 C  standard particle data interface
31650       INTEGER NMXHEP
31651
31652       PARAMETER (NMXHEP=4000)
31653
31654       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31655       DOUBLE PRECISION PHEP,VHEP
31656       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31657      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31658      &                VHEP(4,NMXHEP)
31659 C  extension to standard particle data interface (PHOJET specific)
31660       INTEGER IMPART,IPHIST,ICOLOR
31661       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31662
31663       IF(IMODE.EQ.1) THEN
31664         IF(IDEB(76).GE.26) THEN
31665           WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31666      &      'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31667      &      ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31668           WRITE(LO,'(1X,A,/2X,6I6)')
31669      &      'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31670      &      IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31671         ENDIF
31672         IF(NHEP.EQ.NMXHEP) THEN
31673           WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31674      &      'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31675           CALL PHO_ABORT
31676         ENDIF
31677         NHEP = NHEP+1
31678         IDBAMI = IDBAM
31679         IDPDGI = IDPDG
31680         IF(ABS(ISTH).LE.2) THEN
31681           IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31682             IDPDGI = ipho_id2pdg(IDBAM)
31683           ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31684             IDBAMI = ipho_pdg2id(IDPDG)
31685           ENDIF
31686         ENDIF
31687 C  standard data
31688         ISTHEP(NHEP) = ISTH
31689         IDHEP(NHEP)  = IDPDGI
31690         JMOHEP(1,NHEP) = JM1
31691         JMOHEP(2,NHEP) = JM2
31692 C  update of mother-daugther relations
31693         IF(ABS(ISTH).LE.1) THEN
31694           IF(JM1.GT.0) THEN
31695             IF(JDAHEP(1,JM1).EQ.0) THEN
31696               JDAHEP(1,JM1) = NHEP
31697               ISTHEP(JM1) = 2
31698             ENDIF
31699             JDAHEP(2,JM1) = NHEP
31700           ENDIF
31701           IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31702             IF(JDAHEP(1,JM2).EQ.0) THEN
31703               JDAHEP(1,JM2) = NHEP
31704               ISTHEP(JM2) = 2
31705             ENDIF
31706             JDAHEP(2,JM2) = NHEP
31707           ELSE IF(JM2.LT.0) THEN
31708             DO 100 II=JM1+1,-JM2
31709               IF(JDAHEP(1,II).EQ.0) THEN
31710                 JDAHEP(1,II) = NHEP
31711                 ISTHEP(II) = 2
31712               ENDIF
31713               JDAHEP(2,II) = NHEP
31714 100         CONTINUE
31715           ENDIF
31716         ENDIF
31717         PHEP(1,NHEP) = P1
31718         PHEP(2,NHEP) = P2
31719         PHEP(3,NHEP) = P3
31720         PHEP(4,NHEP) = P4
31721         IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31722           TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31723           PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31724         ELSE
31725           PHEP(5,NHEP) = 0.D0
31726         ENDIF
31727         JDAHEP(1,NHEP) = 0
31728         JDAHEP(2,NHEP) = 0
31729 C  extended information
31730         IMPART(NHEP) = IDBAMI
31731 C  extended history information
31732         IPHIST(1,NHEP) = IPHIS1
31733         IPHIST(2,NHEP) = IPHIS2
31734 C  charge/baryon number or color labels
31735         IF(ISTH.EQ.1) THEN
31736           ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31737           ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31738         ELSE
31739           ICOLOR(1,NHEP) = IC1
31740           ICOLOR(2,NHEP) = IC2
31741         ENDIF
31742
31743         IPOS = NHEP
31744         IF(IDEB(76).GE.26) THEN
31745           WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31746      &      'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31747      &      IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31748      &      PHEP(5,NHEP),IPOS
31749         ENDIF
31750
31751       ELSE IF(IMODE.EQ.0) THEN
31752         NHEP   = 0
31753       ELSE IF(IMODE.EQ.2) THEN
31754         IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31755           WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31756      &      'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31757           RETURN
31758         ENDIF
31759         ISTH  = ISTHEP(IPOS)
31760         IDPDG = IDHEP(IPOS)
31761         IDBAM = IMPART(IPOS)
31762         JM1   = JMOHEP(1,IPOS)
31763         JM2   = JMOHEP(2,IPOS)
31764         P1    = PHEP(1,IPOS)
31765         P2    = PHEP(2,IPOS)
31766         P3    = PHEP(3,IPOS)
31767         P4    = PHEP(4,IPOS)
31768         IPHIS1= IPHIST(1,IPOS)
31769         IPHIS2= IPHIST(2,IPOS)
31770         IC1   = ICOLOR(1,IPOS)
31771         IC2   = ICOLOR(2,IPOS)
31772       ELSE
31773         WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31774       ENDIF
31775       END
31776
31777 *$ CREATE IPHO_CNV1.FOR
31778 *COPY IPHO_CNV1
31779 CDECK  ID>, IPHO_CNV1
31780       INTEGER FUNCTION IPHO_CNV1(IPART)
31781 C*********************************************************************
31782 C
31783 C     conversion of quark numbering scheme to PARTICLE DATA GROUP
31784 C                                             convention
31785 C
31786 C     input:   old internal particle code of hard scattering
31787 C                    0   gluon
31788 C                    1   d
31789 C                    2   u
31790 C                    3   s
31791 C                    4   c
31792 C     valence quarks changed to standard numbering
31793 C
31794 C     output:  standard particle codes
31795 C
31796 C*********************************************************************
31797       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31798       SAVE
31799 C
31800       II = ABS(IPART)
31801 C  change gluon number
31802       IF(II.EQ.0) THEN
31803         IPHO_CNV1 = 21
31804 C  change valence quark
31805       ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31806         IPHO_CNV1 = SIGN(II-6,IPART)
31807       ELSE
31808         IPHO_CNV1 = IPART
31809       ENDIF
31810       END
31811
31812 *$ CREATE PHO_HACODE.FOR
31813 *COPY PHO_HACODE
31814 CDECK  ID>, PHO_HACODE
31815       SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31816 C*********************************************************************
31817 C
31818 C     determination of hadron index from quarks
31819 C
31820 C     input:   ID1,ID2   parton code according to PDG conventions
31821 C
31822 C     output:  IDcpc1,2  CPC particle codes
31823 C
31824 C*********************************************************************
31825
31826       IMPLICIT NONE
31827
31828       SAVE
31829
31830       integer ID1,ID2,IDcpc1,IDcpc2
31831
31832 C  input/output channels
31833       INTEGER LI,LO
31834       COMMON /POINOU/ LI,LO
31835 C  event debugging information
31836       INTEGER NMAXD
31837       PARAMETER (NMAXD=100)
31838       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31839      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31840       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31841      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31842 C  general particle data
31843       double precision xm_list,tau_list,gam_list,
31844      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31845      &  xm_bb82_list,xm_bb102_list
31846       integer          ich3_list,iba3_list,iq_list,
31847      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
31848       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31849      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
31850      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31851      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31852      &  ich3_list(300),iba3_list(300),iq_list(3,300),
31853      &  id_psm_list(6,6),id_vem_list(6,6),
31854      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
31855
31856 C  local variables
31857       integer ii,jj,kk,i1,i2
31858
31859       IDcpc1 = 0
31860       IDcpc2 = 0
31861
31862       if(ID1*ID2.lt.0) then
31863 C  meson
31864         if(ID1.gt.0) then
31865           ii = ID1
31866           jj = -ID2
31867         else
31868           ii = ID2
31869           jj = -ID1
31870         endif
31871         IDcpc1 = ID_psm_list(ii,jj)
31872         IDcpc2 = ID_vem_list(ii,jj)
31873
31874       else
31875 C  baryon
31876         i1 = abs(ID1)
31877         i2 = abs(ID2)
31878         if(i1.gt.6) then
31879           ii = i1/1000
31880           jj = (i1-ii*1000)/100
31881           kk = i2
31882         else
31883           ii = i1
31884           jj = i2/1000
31885           kk = (i2-jj*1000)/100
31886         endif
31887         IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31888         IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31889
31890       endif
31891
31892       END
31893
31894 *$ CREATE PHO_ID2STR.FOR
31895 *COPY PHO_ID2STR
31896 CDECK  ID>, PHO_ID2STR
31897       SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31898 C*********************************************************************
31899 C
31900 C     conversion of quark numbering scheme
31901 C
31902 C     input:   standard particle codes:
31903 C                       ID1
31904 C                       ID2
31905 C
31906 C     output:  NOBAM    CPC string code
31907 C              quark codes (PDG convention):
31908 C                       IBAM1
31909 C                       IBAM2
31910 C                       IBAM3
31911 C                       IBAM4
31912 C
31913 C              NOBAM = -1 invalid flavour combinations
31914 C
31915 C*********************************************************************
31916       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31917       SAVE
31918
31919 C  input/output channels
31920       INTEGER LI,LO
31921       COMMON /POINOU/ LI,LO
31922
31923       IDA1 = ABS(ID1)
31924       IDA2 = ABS(ID2)
31925
31926 C  quark-antiquark string
31927       IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31928         IF((ID1*ID2).GE.0) GOTO 100
31929         IBAM1 = ID1
31930         IBAM2 = ID2
31931         IBAM3 = 0
31932         IBAM4 = 0
31933         NOBAM = 3
31934 C  quark-diquark string
31935       ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31936         IF((ID1*ID2).LE.0) GOTO 100
31937         IBAM1 = ID1
31938         IBAM2 = ID2/1000
31939         IBAM3 = (ID2-IBAM2*1000)/100
31940         IBAM4 = 0
31941         NOBAM = 4
31942 C  diquark-quark string
31943       ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31944         IF((ID1*ID2).LE.0) GOTO 100
31945         IBAM1 = ID1/1000
31946         IBAM2 = (ID1-IBAM1*1000)/100
31947         IBAM3 = ID2
31948         IBAM4 = 0
31949         NOBAM = 6
31950 C  gluon-gluon string
31951       ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31952         IBAM1 = 21
31953         IBAM2 = 21
31954         IBAM3 = 0
31955         IBAM4 = 0
31956         NOBAM = 7
31957 C  diquark-antidiquark string
31958       ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31959         IF((ID1*ID2).GE.0) GOTO 100
31960         IBAM1 = ID1/1000
31961         IBAM2 = (ID1-IBAM1*1000)/100
31962         IBAM3 = ID2/1000
31963         IBAM4 = (ID2-IBAM3*1000)/100
31964         NOBAM = 5
31965       ENDIF
31966       RETURN
31967
31968 C  invalid combination
31969  100  CONTINUE
31970         WRITE(LO,'(//1X,A,2I10)')
31971      &    'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31972         CALL PHO_ABORT
31973
31974       END
31975
31976 *$ CREATE PHO_MKSLTR.FOR
31977 *COPY PHO_MKSLTR
31978 CDECK  ID>, PHO_MKSLTR
31979       SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31980 C********************************************************************
31981 C
31982 C     calculate successive Lorentz boots for arbitrary Lorentz trans.
31983 C
31984 C     input:   P1                initial 4 vector
31985 C              GAM(3),GAMB(3)    Lorentz boost parameters
31986 C
31987 C     output:  P2                final  4 vector
31988 C
31989 C********************************************************************
31990       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31991       SAVE
31992
31993       DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31994
31995       P2(4) = P1(4)
31996       DO 150 I=1,3
31997         P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31998         P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
31999  150  CONTINUE
32000       END
32001
32002 *$ CREATE PHO_GETLTR.FOR
32003 *COPY PHO_GETLTR
32004 CDECK  ID>, PHO_GETLTR
32005       SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
32006 C********************************************************************
32007 C
32008 C     calculate Lorentz boots for arbitrary Lorentz transformation
32009 C
32010 C     input:   P1    initial 4 vector
32011 C              P2    final 4 vector
32012 C
32013 C     output:  GAM(3),GAMB(3)
32014 C              DELE   energy deviation
32015 C              IREJ   0 success
32016 C                     1 failure
32017 C
32018 C********************************************************************
32019       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32020       SAVE
32021
32022       PARAMETER ( DREL = 0.001D0 )
32023
32024 C  input/output channels
32025       INTEGER LI,LO
32026       COMMON /POINOU/ LI,LO
32027
32028       DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
32029
32030       IREJ = 1
32031       DO 50 K=1,4
32032         PA(K) = P1(K)
32033         PP(K) = P1(K)
32034  50   CONTINUE
32035       PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
32036       DO 100 I=1,3
32037         PP(I) = P2(I)
32038         PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
32039         IF(PP(4).LE.0.D0) RETURN
32040         PP(4) = SQRT(PP(4))
32041         GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
32042      &             -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
32043         GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
32044         GAMB(I) = GAMB(I)*GAM(I)
32045         DO 150 K=1,4
32046           PA(K) = PP(K)
32047  150    CONTINUE
32048  100  CONTINUE
32049       DELE = P2(4)-PP(4)
32050       IREJ = 0
32051 C  consistency check
32052 *     IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
32053 *       PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
32054 *       WRITE(LO,'(/1X,A,2E12.5)')
32055 *    &    'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
32056 *       WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
32057 *       WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
32058 *       WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
32059 *       WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
32060 *     ENDIF
32061       END
32062
32063 *$ CREATE PHO_ALTRA.FOR
32064 *COPY PHO_ALTRA
32065 CDECK  ID>, PHO_ALTRA
32066       SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
32067 C*********************************************************************
32068 C
32069 C    arbitrary Lorentz transformation
32070 C
32071 C*********************************************************************
32072       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32073       SAVE
32074
32075       EP=PCX*BGX+PCY*BGY+PCZ*BGZ
32076       PE=EP/(GA+1.D0)+EC
32077       PX=PCX+BGX*PE
32078       PY=PCY+BGY*PE
32079       PZ=PCZ+BGZ*PE
32080       P=SQRT(PX*PX+PY*PY+PZ*PZ)
32081       E=GA*EC+EP
32082
32083       END
32084
32085 *$ CREATE PHO_LTRANS.FOR
32086 *COPY PHO_LTRANS
32087 CDECK  ID>, PHO_LTRANS
32088       SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
32089      &                 PL,CXL,CYL,CZL,EL)
32090 C**********************************************************************
32091 C
32092 C     Lorentz transformation into lab - system
32093 C
32094 C**********************************************************************
32095       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32096       SAVE
32097
32098       PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
32099
32100 C  input/output channels
32101       INTEGER LI,LO
32102       COMMON /POINOU/ LI,LO
32103
32104       SID=SQRT(1.D0-COD*COD)
32105       PLX=P*SID*COF
32106       PLY=P*SID*SIF
32107       PCMZ=P*COD
32108       PLZ=GAM*PCMZ+BGAM*ECM
32109       PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
32110       EL=GAM*ECM+BGAM*PCMZ
32111
32112 C  rotation into the original direction
32113       COZ=PLZ/PL
32114       SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
32115
32116 *      CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
32117
32118       AX=ABS(CX)
32119       AY=ABS(CY)
32120       IF(AX.LT.AY) THEN
32121         AMAX=AY
32122         AMIN=AX
32123       ELSE
32124         AMAX=AX
32125         AMIN=AY
32126       ENDIF
32127       IF (ABS(CX)-TINY) 1,1,2
32128     1 IF (ABS(CY)-TINY) 3,3,2
32129
32130     3 CONTINUE
32131 *     WRITE(LO,*)' PHO_DTRANS CX CY CZ =',CX,CY,CZ
32132       CXL=SIZ*COF
32133       CYL=SIZ*SIF
32134       CZL=COZ*CZ
32135 *     WRITE(LO,*)' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
32136 *     WRITE(LO,*) CXL,CYL,CZL
32137       RETURN
32138
32139     2 CONTINUE
32140       IF(AMAX.GT.TINY2) THEN
32141         AR=AMIN/AMAX
32142         AR=AR*AR
32143         A=AMAX*SQRT(1.D0+AR)
32144       ELSE
32145 *       WRITE(LO,*)' PHO_DTRANS AMAX LE TINY2 '
32146         GOTO 3
32147       ENDIF
32148       XI=SIZ*COF
32149       YI=SIZ*SIF
32150       ZI=COZ
32151       CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
32152       CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
32153       CZL=A*YI+CZ*ZI
32154
32155       END
32156
32157 *$ CREATE PHO_TRANS.FOR
32158 *COPY PHO_TRANS
32159 CDECK  ID>, PHO_TRANS
32160       SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
32161 C**********************************************************************
32162 C
32163 C  rotation of coordinate frame (1) de rotation around y axis
32164 C                               (2) fe rotation around z axis
32165 C  (inverse rotation to PHO_TRANI)
32166 C
32167 C**********************************************************************
32168       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32169       SAVE
32170
32171       X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
32172       Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
32173       Z=-SDE    *XO       +CDE    *ZO
32174
32175       END
32176
32177 *$ CREATE PHO_TRANI.FOR
32178 *COPY PHO_TRANI
32179 CDECK  ID>, PHO_TRANI
32180       SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
32181 C**********************************************************************
32182 C
32183 C  rotation of coordinate frame (1) -fe rotation around z axis
32184 C                               (2) -de rotation around y axis
32185 C  (inverse rotation to PHO_TRANS)
32186 C
32187 C**********************************************************************
32188       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32189       SAVE
32190
32191       X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
32192       Y=-SFE    *XO+CFE*    YO
32193       Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
32194
32195       END
32196
32197 *$ CREATE pho_cpcini.FOR
32198 *COPY pho_cpcini
32199 CDECK  ID>, pho_cpcini
32200       SUBROUTINE pho_cpcini(Nrows,Number,List)
32201 C***********************************************************************
32202 C
32203 C     initialization of particle hash table
32204 C
32205 C     input:   Number     vector with Nrows entries according to PDG
32206 C                         convention
32207 C
32208 C     output:  List       vector with hash table
32209 C
32210 C     (this code is based on the function initpns written by
32211 C      Gerry Lynch, LBL, January 1990)
32212 C
32213 C***********************************************************************
32214
32215       IMPLICIT NONE
32216
32217       SAVE
32218
32219 C  input/output channels
32220       INTEGER LI,LO
32221       COMMON /POINOU/ LI,LO
32222
32223       integer Number(*),List(*),Nrows
32224
32225       Integer Nin,Nout,Ip,I
32226
32227       do I = 1,577
32228         List(I) = 0
32229       enddo
32230
32231 C    Loop over all of the elements in the Number vector
32232
32233         Do 500 Ip = 1,Nrows
32234             Nin = Number(Ip)
32235
32236 C    Calculate a list number for this particle id number
32237             If(Nin.Gt.99999.or.Nin.Le.0) Then
32238                  Nout = -1
32239             Else If(Nin.Le.577) Then
32240                  Nout = Nin
32241             Else
32242                  Nout = Mod(Nin,577)
32243             End If
32244
32245  200        continue
32246
32247             If(Nout.Lt.0) Then
32248 C    Count the bad entries
32249                 WRITE(LO,'(1x,a,i10)')
32250      &            'pho_cpcini: invalid particle ID',Nin
32251                 Go to 500
32252             End If
32253             If(List(Nout).eq.0) Then
32254                 List(Nout) = Ip
32255             Else
32256                 If(Nin.eq.Number(List(Nout))) Then
32257                   WRITE(LO,'(1x,a,i10)')
32258      &              'pho_cpcini: double particle ID',Nin
32259                 End If
32260                 Nout = Nout + 5
32261                 If(Nout.Gt.577) Nout = Mod(Nout, 577)
32262
32263                 Go to 200
32264             End If
32265  500      Continue
32266
32267       END
32268
32269 *$ CREATE ipho_pdg2id.FOR
32270 *COPY ipho_pdg2id
32271 CDECK  ID>, ipho_pdg2id
32272       INTEGER FUNCTION ipho_pdg2id(IDpdg)
32273 C**********************************************************************
32274 C
32275 C     calculation internal particle code using the particle index i
32276 C     according to the PDG proposal.
32277 C
32278 C     input:  IDpdg          PDG particle number
32279 C     output: ipho_pdg2id    internal particle code
32280 C                            (0 for invalid IDpdg)
32281 C
32282 C     the hash algorithm is based on a program by Gerry Lynch
32283 C
32284 C**********************************************************************
32285
32286       IMPLICIT NONE
32287
32288       SAVE
32289
32290       integer IDpdg
32291
32292 C  input/output channels
32293       INTEGER LI,LO
32294       COMMON /POINOU/ LI,LO
32295 C  event debugging information
32296       INTEGER NMAXD
32297       PARAMETER (NMAXD=100)
32298       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32299      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32300       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32301      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32302 C  particle ID translation table
32303       integer         ID_pdg_list,ID_list,ID_pdg_max
32304       character*12    name_list
32305       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32306      &                ID_pdg_max
32307
32308       integer Nin,Nout
32309
32310       Nin = abs(IDpdg)
32311
32312       if((Nin.gt.99999).or.(Nin.eq.0)) then
32313 C  invalid particle number
32314         if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32315      &    'ipho_pdg2id: invalid PDG ID number ',IDpdg
32316         ipho_pdg2id = 0
32317         return
32318       else If(Nin.le.577) then
32319 C  simple case
32320         Nout = Nin
32321       else
32322 C  use hash algorithm
32323         Nout = mod(Nin,577)
32324       endif
32325
32326  100  continue
32327
32328 C  particle not in table
32329       if(ID_list(Nout).Eq.0) then
32330         if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32331      &    'ipho_pdg2id: particle not in table ',IDpdg
32332         ipho_pdg2id = 0
32333         return
32334       endif
32335
32336       if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32337 C  particle ID found
32338         ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32339         return
32340       else
32341 C  increment and try again
32342         Nout = Nout + 5
32343         If(Nout.gt.577) Nout = Mod(Nout,577)
32344         goto 100
32345       endif
32346
32347       END
32348
32349 *$ CREATE IPHO_ID2PDG.FOR
32350 *COPY IPHO_ID2PDG
32351 CDECK  ID>, IPHO_ID2PDG
32352       INTEGER FUNCTION ipho_id2pdg(IDcpc)
32353 C**********************************************************************
32354 C
32355 C     conversion of internal particle code to PDG standard
32356 C
32357 C     input:     IDcpc        internal particle number
32358 C     output:    ipho_id2pdg  PDG particle number
32359 C                             (0 for invalid IDcpc)
32360 C
32361 C**********************************************************************
32362
32363       IMPLICIT NONE
32364
32365       SAVE
32366
32367       integer IDcpc
32368
32369 C  input/output channels
32370       INTEGER LI,LO
32371       COMMON /POINOU/ LI,LO
32372 C  event debugging information
32373       INTEGER NMAXD
32374       PARAMETER (NMAXD=100)
32375       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32376      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32377       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32378      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32379 C  particle ID translation table
32380       integer         ID_pdg_list,ID_list,ID_pdg_max
32381       character*12    name_list
32382       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32383      &                ID_pdg_max
32384
32385       integer IDabs
32386
32387       IDabs = abs(IDcpc)
32388       if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32389         ipho_id2pdg = 0
32390         return
32391       endif
32392
32393       ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32394
32395       END
32396
32397 *$ CREATE IPHO_LU2PDG.FOR
32398 *COPY IPHO_LU2PDG
32399 CDECK  ID>, IPHO_LU2PDG
32400       INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32401 C**********************************************************************
32402 C
32403 C    conversion of JETSET KF code to PDG code
32404 C
32405 C**********************************************************************
32406       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32407       SAVE
32408       PARAMETER (NTAB=10)
32409       DIMENSION LU2PD(2,NTAB)
32410       DATA LU2PD / 4232, 4322,
32411      &             4322, 4232,
32412      &             3212, 3122,
32413      &             3122, 3212,
32414      &            30553, 20553,
32415      &            30443, 20443,
32416      &            20443, 10443,
32417      &            10443, 0,
32418      &            511,   0,
32419      &            10551, 551 /
32420 C
32421       DO 100 I=1,NTAB
32422         IF(LU2PD(1,I).EQ.LUKF) THEN
32423           IPHO_LU2PDG=LU2PD(2,I)
32424           RETURN
32425         ENDIF
32426  100  CONTINUE
32427       IPHO_LU2PDG=LUKF
32428
32429       END
32430
32431 *$ CREATE IPHO_PDG2LU.FOR
32432 *COPY IPHO_PDG2LU
32433 CDECK  ID>, IPHO_PDG2LU
32434       INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32435 C**********************************************************************
32436 C
32437 C    conversion of PDG code to JETSET code
32438 C
32439 C**********************************************************************
32440       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32441       SAVE
32442       PARAMETER (NTAB=8)
32443       DIMENSION LU2PD(2,NTAB)
32444       DATA LU2PD / 4232, 4322,
32445      &             4322, 4232,
32446      &             3212, 3122,
32447      &             3122, 3212,
32448      &            30553, 20553,
32449      &            30443, 20443,
32450      &            20443, 10443,
32451      &            10551, 551 /
32452 C
32453       DO 100 I=1,NTAB
32454         IF(LU2PD(2,I).EQ.IPDG) THEN
32455           IPHO_PDG2LU=LU2PD(1,I)
32456           RETURN
32457         ENDIF
32458  100  CONTINUE
32459       IPHO_PDG2LU=IPDG
32460
32461       END
32462
32463 *$ CREATE pho_pname.FOR
32464 *COPY pho_pname
32465 CDECK  ID>, pho_pname
32466       CHARACTER*15 FUNCTION pho_pname(ID,mode)
32467 C***********************************************************************
32468 C
32469 C     returns particle name for given ID number
32470 C
32471 C     input:  ID      particle ID number
32472 C             mode    0:   ID treated as compressed particle code
32473 C                     1:   ID treated as PDG number
32474 C
32475 C***********************************************************************
32476
32477       IMPLICIT NONE
32478
32479       SAVE
32480
32481       integer ID,mode
32482
32483 C  input/output channels
32484       INTEGER LI,LO
32485       COMMON /POINOU/ LI,LO
32486
32487 C  standard particle data interface
32488       INTEGER NMXHEP
32489
32490       PARAMETER (NMXHEP=4000)
32491
32492       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32493       DOUBLE PRECISION PHEP,VHEP
32494       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32495      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32496      &                VHEP(4,NMXHEP)
32497 C  extension to standard particle data interface (PHOJET specific)
32498       INTEGER IMPART,IPHIST,ICOLOR
32499       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32500
32501 C  particle ID translation table
32502       integer         ID_pdg_list,ID_list,ID_pdg_max
32503       character*12    name_list
32504       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32505      &                ID_pdg_max
32506 C  general particle data
32507       double precision xm_list,tau_list,gam_list,
32508      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32509      &  xm_bb82_list,xm_bb102_list
32510       integer          ich3_list,iba3_list,iq_list,
32511      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32512       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32513      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32514      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32515      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32516      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32517      &  id_psm_list(6,6),id_vem_list(6,6),
32518      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32519
32520 C  external functions
32521       integer ipho_id2pdg,ipho_pdg2id
32522
32523 C  local variables
32524       integer  IDpdg,i,ii,k,l,ichar,i_anti
32525       character*15 name
32526
32527       pho_pname = '(?????????????)'
32528
32529       if(mode.eq.0) then
32530         i = ID
32531         IDpdg = ipho_id2pdg(ID)
32532         if(IDpdg.eq.0) return
32533       else if(mode.eq.1) then
32534         i = ipho_pdg2id(ID)
32535         if(i.eq.0) return
32536         IDpdg = ID
32537       else if(mode.eq.2) then
32538         if(ISTHEP(ID).gt.11) then
32539           if(ISTHEP(ID).eq.20) then
32540             pho_pname = 'hard ini. part.'
32541           else if(ISTHEP(ID).eq.21) then
32542             pho_pname = 'hard fin. part.'
32543           else if(ISTHEP(ID).eq.25) then
32544             pho_pname = 'hard scattering'
32545           else if(ISTHEP(ID).eq.30) then
32546             pho_pname = 'diff. diss.    '
32547           else if(ISTHEP(ID).eq.35) then
32548             pho_pname = 'elastic scatt. '
32549           else if(ISTHEP(ID).eq.40) then
32550             pho_pname = 'central scatt. '
32551           endif
32552           return
32553         endif
32554         IDpdg = IDHEP(ID)
32555         i     = IMPART(ID)
32556       else
32557         WRITE(LO,'(1x,a,2i4)')
32558      &    'pho_pname: invalid arguments (ID,mode): ',ID,mode
32559         return
32560       endif
32561
32562       ii = abs(i)
32563       if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32564
32565       name = name_list(ii)
32566       ichar = ich3_list(ii)*sign(1,i)
32567       if(mod(ichar,3).ne.0) then
32568         ichar = 0
32569       else
32570         ichar = ichar/3
32571       endif
32572
32573 C  find position of first blank character
32574       k = 1
32575  100  continue
32576         k = k+1
32577       if(name(k:k).ne.' ') goto 100
32578
32579 C  append anti-particle sign
32580       if(i.lt.0) then
32581         i_anti = 0
32582         do l=1,3
32583           i_anti = i_anti+iq_list(l,ii)
32584         enddo
32585         if(iba3_list(ii).ne.0) then
32586           name(k:k) = '~'
32587           k = K+1
32588         else if(((i_anti.ne.0).and.(ichar.eq.0))
32589      &          .or.(IDpdg.eq.-12)
32590      &          .or.(IDpdg.eq.-14)
32591      &          .or.(IDpdg.eq.-16)) then
32592           name(k:k) = '~'
32593           k = K+1
32594         endif
32595       endif
32596
32597 C  append charge sign
32598       if(ichar.eq.-2) then
32599         name(k:k+1) = '--'
32600       else if(ichar.eq.-1) then
32601         name(k:k) = '-'
32602       else if(ichar.eq.1) then
32603         name(k:k) = '+'
32604       else if(ichar.eq.2) then
32605         name(k:k+1) = '++'
32606       endif
32607
32608       pho_pname = name
32609
32610       END
32611
32612 *$ CREATE ipho_anti.FOR
32613 *COPY ipho_anti
32614 CDECK  ID>, ipho_anti
32615       INTEGER FUNCTION ipho_anti(ID)
32616 C**********************************************************************
32617 C
32618 C     determine antiparticle for given ID
32619 C
32620 C     input:  ID gives CPC particle number
32621 C
32622 C     output: ipho_anti antiparticle code
32623 C
32624 C**********************************************************************
32625
32626       IMPLICIT NONE
32627
32628       SAVE
32629
32630       integer ID
32631
32632 C  input/output channels
32633       INTEGER LI,LO
32634       COMMON /POINOU/ LI,LO
32635 C  event debugging information
32636       INTEGER NMAXD
32637       PARAMETER (NMAXD=100)
32638       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32639      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32640       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32641      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32642 C  particle ID translation table
32643       integer         ID_pdg_list,ID_list,ID_pdg_max
32644       character*12    name_list
32645       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32646      &                ID_pdg_max
32647 C  general particle data
32648       double precision xm_list,tau_list,gam_list,
32649      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32650      &  xm_bb82_list,xm_bb102_list
32651       integer          ich3_list,iba3_list,iq_list,
32652      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32653       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32654      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32655      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32656      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32657      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32658      &  id_psm_list(6,6),id_vem_list(6,6),
32659      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32660
32661 C  standard particle data interface
32662       INTEGER NMXHEP
32663
32664       PARAMETER (NMXHEP=4000)
32665
32666       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32667       DOUBLE PRECISION PHEP,VHEP
32668       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32669      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32670      &                VHEP(4,NMXHEP)
32671 C  extension to standard particle data interface (PHOJET specific)
32672       INTEGER IMPART,IPHIST,ICOLOR
32673       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32674
32675 C  external functions
32676       integer ipho_id2pdg,ipho_pdg2id
32677
32678 C  local variables
32679       integer IDabs,IDpdg,i_anti,l
32680
32681       ipho_anti = -ID
32682       IDabs = abs(ID)
32683
32684 C  baryons
32685       if(iba3_list(IDabs).ne.0) return
32686
32687 C  charged particles
32688       if(ich3_list(IDabs).ne.0) return
32689
32690 C  K0_s and K0_l
32691       IDpdg = ipho_id2pdg(ID)
32692       if(IDpdg.eq.310) then
32693         ID = ipho_pdg2id(130)
32694         return
32695       else if(IDpdg.eq.130) then
32696         ID = ipho_pdg2id(310)
32697         return
32698       endif
32699
32700 C  neutral mesons with open strangeness, charm, or beauty
32701       i_anti = 0
32702       do l=1,3
32703         i_anti = i_anti+iq_list(l,IDabs)
32704       enddo
32705       if(i_anti.ne.0) return
32706
32707 C  neutrinos
32708       IDpdg = abs(IDpdg)
32709       if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32710
32711       ipho_anti = ID
32712
32713       END
32714
32715 *$ CREATE ipho_chr3.FOR
32716 *COPY ipho_chr3
32717 CDECK  ID>, ipho_chr3
32718       INTEGER FUNCTION ipho_chr3(ID,mode)
32719 C**********************************************************************
32720 C
32721 C     output of three times the electric charge
32722 C
32723 C     input:  mode
32724 C             0   ID gives CPC particle number
32725 C             1   ID gives PDG particle number
32726 C             2   ID gives position of particle in /POEVT1/
32727 C
32728 C**********************************************************************
32729
32730       IMPLICIT NONE
32731
32732       SAVE
32733
32734       integer ID,mode
32735
32736 C  input/output channels
32737       INTEGER LI,LO
32738       COMMON /POINOU/ LI,LO
32739 C  event debugging information
32740       INTEGER NMAXD
32741       PARAMETER (NMAXD=100)
32742       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32743      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32744       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32745      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32746
32747 C  standard particle data interface
32748       INTEGER NMXHEP
32749
32750       PARAMETER (NMXHEP=4000)
32751
32752       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32753       DOUBLE PRECISION PHEP,VHEP
32754       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32755      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32756      &                VHEP(4,NMXHEP)
32757 C  extension to standard particle data interface (PHOJET specific)
32758       INTEGER IMPART,IPHIST,ICOLOR
32759       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32760
32761 C  particle ID translation table
32762       integer         ID_pdg_list,ID_list,ID_pdg_max
32763       character*12    name_list
32764       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32765      &                ID_pdg_max
32766 C  general particle data
32767       double precision xm_list,tau_list,gam_list,
32768      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32769      &  xm_bb82_list,xm_bb102_list
32770       integer          ich3_list,iba3_list,iq_list,
32771      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32772       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32773      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32774      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32775      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32776      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32777      &  id_psm_list(6,6),id_vem_list(6,6),
32778      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32779
32780 C  external functions
32781       integer ipho_pdg2id
32782
32783 C  local variables
32784       integer i,IDpdg
32785
32786       ipho_chr3 = 0
32787
32788       if(mode.eq.0) then
32789         i = ID
32790       else if(mode.eq.1) then
32791         i = ipho_pdg2id(ID)
32792         if(i.eq.0) return
32793         IDpdg = ID
32794       else if(mode.eq.2) then
32795         if(ISTHEP(ID).gt.11) return
32796         i     = IMPART(ID)
32797         IDpdg = IDHEP(ID)
32798         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32799           ipho_chr3 = ICOLOR(1,ID)
32800           return
32801         endif
32802       else
32803         WRITE(LO,'(1x,a,2i4)')
32804      &    'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32805         return
32806       endif
32807
32808       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32809         WRITE(LO,'(1x,a,3i8)')
32810      &    'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32811         ipho_chr3 = 1.D0/dble(i)
32812         call pho_prevnt(0)
32813         return
32814       endif
32815
32816       ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32817
32818       END
32819
32820 *$ CREATE ipho_bar3.FOR
32821 *COPY ipho_bar3
32822 CDECK  ID>, ipho_bar3
32823       INTEGER FUNCTION ipho_bar3(ID,mode)
32824 C**********************************************************************
32825 C
32826 C     output of three times the baryon charge
32827 C
32828 C     index:  MODE
32829 C             0   ID gives CPC particle number
32830 C             1   ID gives PDG particle number
32831 C             2   ID gives position of particle in /POEVT1/
32832 C
32833 C**********************************************************************
32834
32835       IMPLICIT NONE
32836
32837       SAVE
32838
32839       integer ID,mode
32840
32841 C  input/output channels
32842       INTEGER LI,LO
32843       COMMON /POINOU/ LI,LO
32844 C  event debugging information
32845       INTEGER NMAXD
32846       PARAMETER (NMAXD=100)
32847       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32848      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32849       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32850      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32851
32852 C  standard particle data interface
32853       INTEGER NMXHEP
32854
32855       PARAMETER (NMXHEP=4000)
32856
32857       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32858       DOUBLE PRECISION PHEP,VHEP
32859       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32860      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32861      &                VHEP(4,NMXHEP)
32862 C  extension to standard particle data interface (PHOJET specific)
32863       INTEGER IMPART,IPHIST,ICOLOR
32864       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32865
32866 C  particle ID translation table
32867       integer         ID_pdg_list,ID_list,ID_pdg_max
32868       character*12    name_list
32869       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32870      &                ID_pdg_max
32871 C  general particle data
32872       double precision xm_list,tau_list,gam_list,
32873      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32874      &  xm_bb82_list,xm_bb102_list
32875       integer          ich3_list,iba3_list,iq_list,
32876      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32877       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32878      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32879      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32880      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32881      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32882      &  id_psm_list(6,6),id_vem_list(6,6),
32883      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32884
32885 C  external functions
32886       integer ipho_pdg2id
32887
32888 C  local variables
32889       integer i,IDpdg
32890
32891       ipho_bar3 = 0
32892
32893       if(mode.eq.0) then
32894         i = ID
32895       else if(mode.eq.1) then
32896         i = ipho_pdg2id(ID)
32897         if(i.eq.0) return
32898         IDpdg = ID
32899       else if(mode.eq.2) then
32900         if(ISTHEP(ID).gt.11) return
32901         i     = IMPART(ID)
32902         IDpdg = IDHEP(ID)
32903         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32904           ipho_bar3 = ICOLOR(2,ID)
32905           return
32906         endif
32907       else
32908         WRITE(LO,'(1x,a,2i4)')
32909      &    'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32910         return
32911       endif
32912
32913       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32914         WRITE(LO,'(1x,a,3i8)')
32915      &    'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32916         ipho_bar3 = 1.D0/dble(i)
32917         return
32918       endif
32919
32920       ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32921
32922       END
32923
32924 *$ CREATE pho_pmass.FOR
32925 *COPY pho_pmass
32926 CDECK  ID>, pho_pmass
32927       DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32928 C***********************************************************************
32929 C
32930 C     particle mass
32931 C
32932 C     input:  mode  -1   initialization
32933 C                    0   ID gives CPC particle number
32934 C                    1   ID gives PDG particle number,
32935 C                        (for quarks current masses are returned)
32936 C                    2   ID gives position of particle in /POEVT1/
32937 C                    3   ID gives PDG parton number,
32938 C                        (for quarks constituent masses are returned)
32939 C
32940 C     output: average particle mass (in GeV)
32941 C
32942 C***********************************************************************
32943
32944       IMPLICIT NONE
32945
32946       SAVE
32947
32948       integer ID,mode,MSTJ24
32949
32950 C  input/output channels
32951       INTEGER LI,LO
32952       COMMON /POINOU/ LI,LO
32953 C  event debugging information
32954       INTEGER NMAXD
32955       PARAMETER (NMAXD=100)
32956       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32957      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32958       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32959      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32960 C  model switches and parameters
32961       CHARACTER*8 MDLNA
32962       INTEGER ISWMDL,IPAMDL
32963       DOUBLE PRECISION PARMDL
32964       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32965
32966 C  standard particle data interface
32967       INTEGER NMXHEP
32968
32969       PARAMETER (NMXHEP=4000)
32970
32971       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32972       DOUBLE PRECISION PHEP,VHEP
32973       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32974      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32975      &                VHEP(4,NMXHEP)
32976 C  extension to standard particle data interface (PHOJET specific)
32977       INTEGER IMPART,IPHIST,ICOLOR
32978       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32979
32980 C  particle ID translation table
32981       integer         ID_pdg_list,ID_list,ID_pdg_max
32982       character*12    name_list
32983       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32984      &                ID_pdg_max
32985 C  general particle data
32986       double precision xm_list,tau_list,gam_list,
32987      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32988      &  xm_bb82_list,xm_bb102_list
32989       integer          ich3_list,iba3_list,iq_list,
32990      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32991       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32992      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32993      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32994      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32995      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32996      &  id_psm_list(6,6),id_vem_list(6,6),
32997      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32998
32999       INTEGER MSTU,MSTJ
33000       DOUBLE PRECISION PARU,PARJ
33001       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33002
33003 C  external functions
33004       integer ipho_pdg2id,ipho_id2pdg
33005
33006       DOUBLE PRECISION PYMASS
33007
33008 C  local variables
33009       integer i,IDpdg
33010
33011       pho_pmass = 0.D0
33012
33013       if(mode.eq.0) then
33014         i = ID
33015       else if(mode.eq.1) then
33016         i = ipho_pdg2id(ID)
33017         if(i.eq.0) return
33018       else if(mode.eq.2) then
33019         if(ISTHEP(ID).gt.11) return
33020         i     = IMPART(ID)
33021         IDpdg = IDHEP(ID)
33022         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
33023           pho_pmass = PHEP(5,ID)
33024           return
33025         endif
33026       else if(mode.eq.3) then
33027         i = abs(ID)
33028         if((i.gt.0).and.(i.le.6)) then
33029           pho_pmass = PARMDL(150+i)
33030           return
33031         else
33032           i = ipho_pdg2id(ID)
33033           if(i.eq.0) return
33034         endif
33035       else if(mode.eq.-1) then
33036 C  initialization: take masses for quarks and di-quarks from JETSET
33037         MSTJ24 = MSTJ(24)
33038         MSTJ(24) = 0
33039         do i=1,22
33040           IDpdg = ipho_id2pdg(i)
33041
33042           xm_list(i) = PYMASS(IDpdg)
33043
33044         enddo
33045         MSTJ(24) = MSTJ24
33046         return
33047       else
33048         WRITE(LO,'(1x,a,2i4)')
33049      &    'pho_pmass: invalid arguments (ID,mode): ',ID,mode
33050         return
33051       endif
33052
33053       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
33054         WRITE(LO,'(1x,a,2i8)')
33055      &    'pho_pmass: invalid arguments (ID,mode): ',ID,mode
33056         pho_pmass = 1.D0/dble(i)
33057         return
33058       endif
33059
33060       pho_pmass = xm_list(iabs(i))
33061
33062       END
33063
33064 *$ CREATE PHO_MEMASS.FOR
33065 *COPY PHO_MEMASS
33066 CDECK  ID>, PHO_MEMASS
33067       SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
33068 C**********************************************************************
33069 C
33070 C     determine meson masses corresponding to the input flavours
33071 C
33072 C     input: I,J,K     quark flavours (PDG convention)
33073 C
33074 C     output: AMPS     pseudo scalar meson mass
33075 C             AMPS2    next possible two particle configuration
33076 C                      (two pseudo scalar  mesons)
33077 C             AMVE     vector meson mass
33078 C             AMVE2    next possible two particle configuration
33079 C                      (two vector mesons)
33080 C             IPS,IVE  meson numbers in CPC
33081 C
33082 C**********************************************************************
33083
33084       IMPLICIT NONE
33085
33086       SAVE
33087
33088       integer I,J,IPS,IVE
33089       double precision AMPS,AMPS2,AMVE,AMVE2
33090
33091 C  input/output channels
33092       INTEGER LI,LO
33093       COMMON /POINOU/ LI,LO
33094 C  event debugging information
33095       INTEGER NMAXD
33096       PARAMETER (NMAXD=100)
33097       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33098      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33099       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33100      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33101 C  particle ID translation table
33102       integer         ID_pdg_list,ID_list,ID_pdg_max
33103       character*12    name_list
33104       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
33105      &                ID_pdg_max
33106 C  general particle data
33107       double precision xm_list,tau_list,gam_list,
33108      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
33109      &  xm_bb82_list,xm_bb102_list
33110       integer          ich3_list,iba3_list,iq_list,
33111      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
33112       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33113      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
33114      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33115      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33116      &  ich3_list(300),iba3_list(300),iq_list(3,300),
33117      &  id_psm_list(6,6),id_vem_list(6,6),
33118      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
33119
33120 C  local variables
33121       integer ii,jj
33122
33123       IF(I.GT.0) THEN
33124         ii = I
33125         jj = -J
33126       ELSE
33127         ii = J
33128         jj = -I
33129       ENDIF
33130
33131 C  particle ID's
33132       IPS = id_psm_list(ii,jj)
33133       IVE = id_vem_list(ii,jj)
33134 C  masses
33135       if(IPS.ne.0) then
33136         AMPS = xm_list(iabs(IPS))
33137       else
33138         AMPS = 0.D0
33139       endif
33140       if(IVE.ne.0) then
33141         AMVE = xm_list(iabs(IVE))
33142       else
33143         AMVE = 0.D0
33144       endif
33145
33146 C  next possible two-particle configurations (add phase space)
33147       AMPS2 = xm_psm2_list(ii,jj)*1.5D0
33148       AMVE2 = xm_vem2_list(ii,jj)*1.1D0
33149
33150       END
33151
33152 *$ CREATE PHO_BAMASS.FOR
33153 *COPY PHO_BAMASS
33154 CDECK  ID>, PHO_BAMASS
33155       SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
33156 C**********************************************************************
33157 C
33158 C     determine baryon masses corresponding to the input flavours
33159 C
33160 C     input: I,J,K     quark flavours (PDG convention)
33161 C
33162 C     output: AM8      octett baryon mass
33163 C             AM82     next possible two particle configuration
33164 C                      (octett baryon and meson)
33165 C             AM10     decuplett baryon mass
33166 C             AM102    next possible two particle configuration
33167 C                      (decuplett baryon and meson,
33168 C                       baryon built up from first two quarks)
33169 C             I8,I10   internal baryon numbers
33170 C
33171 C**********************************************************************
33172
33173       IMPLICIT NONE
33174
33175       SAVE
33176
33177       integer I,J,K,I8,I10
33178       double precision AM8,AM82,AM10,AM102
33179
33180 C  input/output channels
33181       INTEGER LI,LO
33182       COMMON /POINOU/ LI,LO
33183 C  event debugging information
33184       INTEGER NMAXD
33185       PARAMETER (NMAXD=100)
33186       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33187      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33188       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33189      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33190 C  particle ID translation table
33191       integer         ID_pdg_list,ID_list,ID_pdg_max
33192       character*12    name_list
33193       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
33194      &                ID_pdg_max
33195 C  general particle data
33196       double precision xm_list,tau_list,gam_list,
33197      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
33198      &  xm_bb82_list,xm_bb102_list
33199       integer          ich3_list,iba3_list,iq_list,
33200      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
33201       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33202      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
33203      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33204      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33205      &  ich3_list(300),iba3_list(300),iq_list(3,300),
33206      &  id_psm_list(6,6),id_vem_list(6,6),
33207      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
33208
33209 C  local variables
33210       integer ii,jj,kk
33211
33212 C  find particle ID's
33213       ii = iabs(I)
33214       jj = iabs(J)
33215       kk = iabs(K)
33216       I8  = id_b8_list(ii,jj,kk)
33217       I10 = id_b10_list(ii,jj,kk)
33218
33219 C  masses (if combination possible)
33220       if(I8.ne.0) then
33221         AM8 = xm_list(I8)
33222         I8  = sign(I8,i)
33223       else
33224         AM8 = 0.D0
33225       endif
33226       if(I10.ne.0) then
33227         AM10 = xm_list(I10)
33228         I10  = sign(I10,i)
33229       else
33230         AM10 = 0.D0
33231       endif
33232
33233 C  next possible two-particle configurations (add phase space)
33234       AM82  = xm_b82_list(ii,jj,kk)*1.5D0
33235       AM102 = xm_b102_list(ii,jj,kk)*1.1D0
33236
33237       END
33238
33239 *$ CREATE PHO_DQMASS.FOR
33240 *COPY PHO_DQMASS
33241 CDECK  ID>, PHO_DQMASS
33242       SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
33243 C**********************************************************************
33244 C
33245 C     determine minimal masses corresponding to the input flavours
33246 C     (diquark a-diquark string system)
33247 C
33248 C     input: I,J,K,L   quark flavours (PDG convention)
33249 C
33250 C     output: AM82     mass of two octett baryons
33251 C             AM102    mass of two decuplett baryons
33252 C
33253 C**********************************************************************
33254
33255       IMPLICIT NONE
33256
33257       SAVE
33258
33259       integer I,J,K,L
33260       double precision AM82,AM102
33261
33262 C  input/output channels
33263       INTEGER LI,LO
33264       COMMON /POINOU/ LI,LO
33265 C  event debugging information
33266       INTEGER NMAXD
33267       PARAMETER (NMAXD=100)
33268       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33269      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33270       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33271      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33272 C  general particle data
33273       double precision xm_list,tau_list,gam_list,
33274      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
33275      &  xm_bb82_list,xm_bb102_list
33276       integer          ich3_list,iba3_list,iq_list,
33277      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
33278       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33279      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
33280      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33281      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33282      &  ich3_list(300),iba3_list(300),iq_list(3,300),
33283      &  id_psm_list(6,6),id_vem_list(6,6),
33284      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
33285
33286 C  local variables
33287       integer ii,jj,kk,ll
33288
33289       ii = iabs(i)
33290       kk = iabs(k)
33291       jj = iabs(j)
33292       ll = iabs(l)
33293
33294       AM82  = xm_bb82_list(ii,jj,kk,ll)
33295       AM102 = xm_bb102_list(ii,jj,kk,ll)
33296
33297       END
33298
33299 *$ CREATE PHO_CHECK.FOR
33300 *COPY PHO_CHECK
33301 CDECK  ID>, PHO_CHECK
33302       SUBROUTINE PHO_CHECK(MD,IDEV)
33303 C**********************************************************************
33304 C
33305 C     check quantum numbers of entries in /POEVT1/ and /POEVT2/
33306 C           (energy, momentum, charge, baryon number conservation)
33307 C
33308 C     input:    MD      -1  check overall momentum conservation
33309 C                           and perform detailed check only in case of
33310 C                           deviations
33311 C                        1  test all branchings, mother-daughter
33312 C                           relations
33313 C
33314 C     output:   IDEV     0  no deviations
33315 C                        1  deviations found
33316 C
33317 C**********************************************************************
33318       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33319       SAVE
33320
33321 C  input/output channels
33322       INTEGER LI,LO
33323       COMMON /POINOU/ LI,LO
33324 C  event debugging information
33325       INTEGER NMAXD
33326       PARAMETER (NMAXD=100)
33327       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33328      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33329       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33330      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33331 C  model switches and parameters
33332       CHARACTER*8 MDLNA
33333       INTEGER ISWMDL,IPAMDL
33334       DOUBLE PRECISION PARMDL
33335       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33336 C  global event kinematics and particle IDs
33337       INTEGER IFPAP,IFPAB
33338       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33339       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33340 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
33341       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33342       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33343       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33344      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33345
33346 C  standard particle data interface
33347       INTEGER NMXHEP
33348
33349       PARAMETER (NMXHEP=4000)
33350
33351       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33352       DOUBLE PRECISION PHEP,VHEP
33353       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33354      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33355      &                VHEP(4,NMXHEP)
33356 C  extension to standard particle data interface (PHOJET specific)
33357       INTEGER IMPART,IPHIST,ICOLOR
33358       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33359
33360 C  color string configurations including collapsed strings and hadrons
33361       INTEGER MSTR
33362       PARAMETER (MSTR=500)
33363       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33364       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33365      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33366      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33367
33368 C  count number of errors to avoid disk overflow
33369       DATA IERR / 0 /
33370
33371       IDEV = 0
33372 C  conservation check suppressed
33373       IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33374
33375       IF(IPAMDL(13).GT.0) THEN
33376
33377 C  DPMJET call with x limitations
33378         MODE = -1
33379         ECM1 = SQRT(XPSUB*XTSUB)*ECM
33380
33381       ELSE
33382
33383 C  standard call
33384         MODE = MD
33385 C  first two entries are considered as scattering particles
33386         EE1 = PHEP(4,1) + PHEP(4,2)
33387         PX1 = PHEP(1,1) + PHEP(1,2)
33388         PY1 = PHEP(2,1) + PHEP(2,2)
33389         PZ1 = PHEP(3,1) + PHEP(3,2)
33390
33391       ENDIF
33392
33393       DDREL = PARMDL(75)
33394       DDABS = PARMDL(76)
33395       IF(MODE.EQ.-1) GOTO 500
33396
33397  50   CONTINUE
33398
33399       I = 1
33400  100  CONTINUE
33401
33402 C  recognize only decayed particles as mothers
33403         IF(ISTHEP(I).EQ.2) THEN
33404 C  search for other mother particles
33405           K = JDAHEP(1,I)
33406           IF(K.EQ.0) THEN
33407             IF(IPAMDL(178).NE.0)
33408      &        WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33409      &        'entry marked as decayed but no dauther given:',I
33410             GOTO 99
33411           ENDIF
33412           K1 = JMOHEP(1,K)
33413           K2 = JMOHEP(2,K)
33414 C  sum over mother particles
33415           ICH1 = IPHO_CHR3(K1,2)
33416           IBA1 = IPHO_BAR3(K1,2)
33417           EE1 = PHEP(4,K1)
33418           PX1 = PHEP(1,K1)
33419           PY1 = PHEP(2,K1)
33420           PZ1 = PHEP(3,K1)
33421           IF(K2.LT.0) THEN
33422             K2 = -K2
33423             IF((K1.GT.I).OR.(K2.LT.I)) THEN
33424               WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33425      &          'inconsistent mother/daughter relation found',I,K1,K2
33426               CALL PHO_PREVNT(-1)
33427             ENDIF
33428             DO 400 II=K1+1,K2
33429               IF(ABS(ISTHEP(II)).LE.2) THEN
33430                 ICH1 = ICH1 + IPHO_CHR3(II,2)
33431                 IBA1 = IBA1 + IPHO_BAR3(II,2)
33432                 EE1 = EE1 + PHEP(4,II)
33433                 PX1 = PX1 + PHEP(1,II)
33434                 PY1 = PY1 + PHEP(2,II)
33435                 PZ1 = PZ1 + PHEP(3,II)
33436               ENDIF
33437  400        CONTINUE
33438           ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33439             ICH1 = ICH1 + IPHO_CHR3(K2,2)
33440             IBA1 = IBA1 + IPHO_BAR3(K2,2)
33441             EE1 = EE1 + PHEP(4,K2)
33442             PX1 = PX1 + PHEP(1,K2)
33443             PY1 = PY1 + PHEP(2,K2)
33444             PZ1 = PZ1 + PHEP(3,K2)
33445           ENDIF
33446
33447 C  sum over daughter particles
33448           ICH2 = 0.D0
33449           IBA2 = 0.D0
33450           EE2 = 0.D0
33451           PX2 = 0.D0
33452           PY2 = 0.D0
33453           PZ2 = 0.D0
33454           DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33455             IF(ABS(ISTHEP(II)).LE.2) THEN
33456               ICH2 = ICH2 + IPHO_CHR3(II,2)
33457               IBA2 = IBA2 + IPHO_BAR3(II,2)
33458               EE2 = EE2 + PHEP(4,II)
33459               PX2 = PX2 + PHEP(1,II)
33460               PY2 = PY2 + PHEP(2,II)
33461               PZ2 = PZ2 + PHEP(3,II)
33462             ENDIF
33463  200      CONTINUE
33464
33465 C  conservation check
33466           ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33467           IF(ABS(EE1-EE2).GT.ESC) THEN
33468             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33469      &        'PHO_CHECK: energy conservation violated for',
33470      &        'entry,initial,final:',I,EE1,EE2
33471             IDEV = 1
33472           ENDIF
33473           ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33474           IF(ABS(PX1-PX2).GT.ESC) THEN
33475             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33476      &        'PHO_CHECK: x-momentum conservation violated for',
33477      &        'entry,initial,final:',I,PX1,PX2
33478             IDEV = 1
33479           ENDIF
33480           ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33481           IF(ABS(PY1-PY2).GT.ESC) THEN
33482             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33483      &        'PHO_CHECK: y-momentum conservation violated for',
33484      &        'entry,initial,final:',I,PY1,PY2
33485             IDEV = 1
33486           ENDIF
33487           ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33488           IF(ABS(PZ1-PZ2).GT.ESC) THEN
33489             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33490      &        'PHO_CHECK: z-momentum conservation violated for',
33491      &        'entry,initial,final:',I,PZ1,PZ2
33492             IDEV = 1
33493           ENDIF
33494           IF(ICH1.NE.ICH2) THEN
33495             WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33496      &        'PHO_CHECK: charge conservation violated for',
33497      &        'entry,initial,final:',I,ICH1,ICH2
33498             IDEV = 1
33499           ENDIF
33500           IF(IBA1.NE.IBA2) THEN
33501             WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33502      &        'baryon charge conservation violated for',
33503      &        'entry,initial,final:',I,IBA1,IBA2
33504             IDEV = 1
33505           ENDIF
33506           IF(IDEB(20).GE.35) THEN
33507             WRITE(LO,
33508      &        '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33509      &      'PHO_CHECK diagnostics:',
33510      &      '(1.mother/l.mother,1.daughter/l.daughter):',
33511      &      K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33512      &      'mother momenta   ',PX1,PY1,PZ1,EE1,
33513      &      'daughter momenta ',PX2,PY2,PZ2,EE2,
33514      &      'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33515           ENDIF
33516         ENDIF
33517  99     CONTINUE
33518         I = I+1
33519       IF(I.LE.NHEP) GOTO 100
33520
33521  55   CONTINUE
33522
33523       IERR = IERR+IDEV
33524
33525 C  write complete event in case of deviations
33526       IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33527         CALL PHO_PREVNT(1)
33528         IF(ISTR.GT.0) THEN
33529           CALL PHO_PRSTRG
33530
33531           IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33532
33533         ENDIF
33534       ENDIF
33535
33536 C  stop after too many errors
33537       IF(IERR.GT.IPAMDL(179)) THEN
33538         WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33539      &    'too many inconsistencies found, program terminated',IERR
33540         CALL PHO_ABORT
33541       ENDIF
33542
33543       RETURN
33544
33545 C  overall check only (less time consuming)
33546
33547  500  CONTINUE
33548
33549       ICH2 = 0.D0
33550       IBA2 = 0.D0
33551       EE2 = 0.D0
33552       PX2 = 0.D0
33553       PY2 = 0.D0
33554       PZ2 = 0.D0
33555
33556       DO 300 K=3,NHEP
33557 C  recognize only existing particles as possible daughters
33558         IF(ABS(ISTHEP(K)).EQ.1) THEN
33559           ICH2 = ICH2 + IPHO_CHR3(K,2)
33560           IBA2 = IBA2 + IPHO_BAR3(K,2)
33561           EE2 = EE2 + PHEP(4,K)
33562           PX2 = PX2 + PHEP(1,K)
33563           PY2 = PY2 + PHEP(2,K)
33564           PZ2 = PZ2 + PHEP(3,K)
33565         ENDIF
33566  300  CONTINUE
33567
33568 C  check energy-momentum conservation
33569       ESC = ECM*DDREL
33570
33571       IF(IPAMDL(13).GT.0) THEN
33572
33573 C  DPMJET call with x limitations
33574         ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33575         IF(ABS(ECM1-ECM2).GT.ESC) THEN
33576           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33577      &      'PHO_CHECK: c.m. energy conservation violated',
33578      &      'initial/final energy:',ECM1,ECM2
33579           IDEV = 1
33580         ENDIF
33581
33582       ELSE
33583
33584 C  standard call
33585         IF(ABS(EE1-EE2).GT.ESC) THEN
33586           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33587      &      'PHO_CHECK: energy conservation violated',
33588      &      'initial/final energy:',EE1,EE2
33589           IDEV = 1
33590         ENDIF
33591         IF(ABS(PX1-PX2).GT.ESC) THEN
33592         WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33593      &      'PHO_CHECK: x-momentum conservation violated',
33594      &      'initial/final x-momentum:',PX1,PX2
33595           IDEV = 1
33596         ENDIF
33597         IF(ABS(PY1-PY2).GT.ESC) THEN
33598           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33599      &      'PHO_CHECK: y-momentum conservation violated',
33600      &      'initial/final y-momentum:',PY1,PY2
33601           IDEV = 1
33602         ENDIF
33603         IF(ABS(PZ1-PZ2).GT.ESC) THEN
33604           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33605      &      'PHO_CHECK: z-momentum conservation violated',
33606      &      'initial/final z-momentum:',PZ1,PZ2
33607           IDEV = 1
33608         ENDIF
33609
33610 C  check of quantum number conservation
33611
33612         ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33613         IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33614
33615         IF(ICH1.NE.ICH2) THEN
33616           WRITE(LO,'(1X,A,/,5X,A,2I5)')
33617      &      'PHO_CHECK: charge conservation violated',
33618      &      'initial/final charge sum',ICH1,ICH2
33619           IDEV = 1
33620         ENDIF
33621         IF(IBA1.NE.IBA2) THEN
33622           WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33623      &      'baryonic charge conservation violated',
33624      &      'initial/final baryonic charge sum',IBA1,IBA2
33625           IDEV = 1
33626         ENDIF
33627
33628       ENDIF
33629
33630 C  perform detailed checks in case of deviations
33631       IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33632         IF(IPAMDL(13).GT.0) THEN
33633           GOTO 55
33634         ELSE
33635           DDREL = DDREL/2.D0
33636           DDABS = DDABS/2.D0
33637           WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33638      &      'increasing precision of tests to',DDREL,DDABS
33639           GOTO 50
33640         ENDIF
33641       ENDIF
33642
33643       END
33644
33645 *$ CREATE PHO_ABORT.FOR
33646 *COPY PHO_ABORT
33647 CDECK  ID>, PHO_ABORT
33648       SUBROUTINE PHO_ABORT
33649 C**********************************************************************
33650 C
33651 C     top MC event generation due to fatal error,
33652 C     print all information of event generation and history
33653 C
33654 C**********************************************************************
33655       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33656       SAVE
33657
33658 C  input/output channels
33659       INTEGER LI,LO
33660       COMMON /POINOU/ LI,LO
33661 C  event debugging information
33662       INTEGER NMAXD
33663       PARAMETER (NMAXD=100)
33664       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33665      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33666       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33667      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33668 C  model switches and parameters
33669       CHARACTER*8 MDLNA
33670       INTEGER ISWMDL,IPAMDL
33671       DOUBLE PRECISION PARMDL
33672       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33673
33674 C  standard particle data interface
33675       INTEGER NMXHEP
33676
33677       PARAMETER (NMXHEP=4000)
33678
33679       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33680       DOUBLE PRECISION PHEP,VHEP
33681       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33682      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33683      &                VHEP(4,NMXHEP)
33684 C  extension to standard particle data interface (PHOJET specific)
33685       INTEGER IMPART,IPHIST,ICOLOR
33686       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33687
33688 C  color string configurations including collapsed strings and hadrons
33689       INTEGER MSTR
33690       PARAMETER (MSTR=500)
33691       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33692       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33693      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33694      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33695 C  light-cone x fractions and c.m. momenta of soft cut string ends
33696       INTEGER MAXSOF
33697       PARAMETER ( MAXSOF = 50 )
33698       INTEGER IJSI2,IJSI1
33699       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33700       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33701      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33702      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
33703 C  hard scattering data
33704       INTEGER MSCAHD
33705       PARAMETER ( MSCAHD = 50 )
33706       INTEGER LSCAHD,LSC1HD,LSIDX,
33707      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33708       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33709       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33710      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33711      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33712      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33713      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33714      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33715      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33716
33717       WRITE(LO,'(//,1X,A,/,1X,A)')
33718      &  'PHO_ABORT: program execution stopped',
33719      &  '===================================='
33720       WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33721 C
33722       CALL PHO_SETMDL(0,0,-2)
33723       CALL PHO_PREVNT(-1)
33724       CALL PHO_ACTPDF(0,-2)
33725 C  print selected parton flavours
33726       WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33727       DO 700 I=1,KSOFT
33728         WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33729  700  CONTINUE
33730       WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33731       DO 750 K=1,KHARD
33732         I = LSIDX(K)
33733         WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33734         WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33735      &    NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33736  750  CONTINUE
33737 C  print selected parton momenta
33738       WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33739       DO 300 I=1,KSOFT
33740         WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33741         WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33742  300  CONTINUE
33743       WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33744       DO 350 K=1,KHARD
33745         I = LSIDX(K)
33746         I3 = 8*I-4
33747         WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33748         WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33749  350  CONTINUE
33750
33751 C  print /POEVT1/
33752       CALL PHO_PREVNT(0)
33753
33754 C  fragmentation process
33755       IF(ISTR.GT.0) THEN
33756 C  print /POSTRG/
33757         CALL PHO_PRSTRG
33758
33759         IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33760
33761       ENDIF
33762
33763 C  last message
33764       WRITE(LO,'(////5X,A,///5X,A,///)')
33765      &  'PHO_ABORT: execution terminated due to fatal error',
33766      &'*** Simulating division by zero to get traceback information ***'
33767       ISTR = 100/IPAMDL(100)
33768
33769       END
33770
33771 *$ CREATE PHO_TRACE.FOR
33772 *COPY PHO_TRACE
33773 CDECK  ID>, PHO_TRACE
33774       SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33775 C**********************************************************************
33776 C
33777 C     trace program subroutines according to level,
33778 C                          original output levels will be saved
33779 C
33780 C     input:   ISTART      first event to trace
33781 C              ISWI        number of events to trace
33782 C                                0   loop call, use old values
33783 C                               -1   restore original output levels
33784 C                                1   store level and wait for event
33785 C              LEVEL       desired output level
33786 C                                0   standard output
33787 C                                3   internal rejections
33788 C                                5   cross sections, slopes etc.
33789 C                               10   parameter of subroutines and
33790 C                                    results
33791 C                               20   huge amount of debug output
33792 C                               30   maximal possible output
33793 C
33794 C**********************************************************************
33795       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33796       SAVE
33797
33798 C  input/output channels
33799       INTEGER LI,LO
33800       COMMON /POINOU/ LI,LO
33801 C  event debugging information
33802       INTEGER NMAXD
33803       PARAMETER (NMAXD=100)
33804       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33805      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33806       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33807      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33808
33809       DIMENSION IMEM(NMAXD)
33810
33811 C  protect ISWI
33812       ISW = ISWI
33813  10   CONTINUE
33814       IF(ISW.EQ.0) THEN
33815         IF(KEVENT.LT.ION) THEN
33816           RETURN
33817         ELSE IF(KEVENT.EQ.ION) THEN
33818           WRITE(LO,'(///,1X,A,///)')
33819      &      'PHO_TRACE: trace mode switched on'
33820           DO 100 I=1,NMAXD
33821             IMEM(I) = IDEB(I)
33822             IDEB(I) = MAX(ILEVEL,IMEM(I))
33823  100      CONTINUE
33824         ELSE IF(KEVENT.EQ.IOFF) THEN
33825           WRITE(LO,'(//,1X,A,///)')
33826      &      'PHO_TRACE: trace mode switched off'
33827           DO 200 I=1,NMAXD
33828             IDEB(I) = IMEM(I)
33829  200      CONTINUE
33830         ENDIF
33831       ELSE IF(ISW.EQ.-1) THEN
33832         DO 300 I=1,NMAXD
33833           IDEB(I) = IMEM(I)
33834  300    CONTINUE
33835       ELSE
33836 C  save information
33837         ION = ISTART
33838         IOFF = ISTART+ISW
33839         ILEVEL = LEVEL
33840       ENDIF
33841 C  check coincidence
33842       IF(ISW.GT.0) THEN
33843         ISW=0
33844         ILEVEL = LEVEL
33845         GOTO 10
33846       ENDIF
33847
33848       END
33849
33850 *$ CREATE PHO_PRSTRG.FOR
33851 *COPY PHO_PRSTRG
33852 CDECK  ID>, PHO_PRSTRG
33853       SUBROUTINE PHO_PRSTRG
33854 C**********************************************************************
33855 C
33856 C     print information of /POSTRG/
33857 C
33858 C**********************************************************************
33859       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33860       SAVE
33861
33862 C  input/output channels
33863       INTEGER LI,LO
33864       COMMON /POINOU/ LI,LO
33865 C  event debugging information
33866       INTEGER NMAXD
33867       PARAMETER (NMAXD=100)
33868       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33869      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33870       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33871      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33872
33873 C  standard particle data interface
33874       INTEGER NMXHEP
33875
33876       PARAMETER (NMXHEP=4000)
33877
33878       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33879       DOUBLE PRECISION PHEP,VHEP
33880       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33881      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33882      &                VHEP(4,NMXHEP)
33883 C  extension to standard particle data interface (PHOJET specific)
33884       INTEGER IMPART,IPHIST,ICOLOR
33885       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33886
33887 C  color string configurations including collapsed strings and hadrons
33888       INTEGER MSTR
33889       PARAMETER (MSTR=500)
33890       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33891       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33892      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33893      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33894
33895       WRITE(LO,'(/,1X,A,I5)')
33896      &  'PHO_PRSTRG: number of strings soft+hard:',ISTR
33897       WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33898      &  ' NOBAM  ID1  ID2  ID3  ID4     NPO1/2/3/4        MASS'
33899       WRITE(LO,'(1X,A)')
33900      &  ' ======================================================='
33901       DO 800 I=1,ISTR
33902         WRITE(LO,'(1X,9I5,1P,E11.3)')
33903      &         NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33904      &         NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33905  800  CONTINUE
33906
33907       END
33908
33909 *$ CREATE PHO_PREVNT.FOR
33910 *COPY PHO_PREVNT
33911 CDECK  ID>, PHO_PREVNT
33912       SUBROUTINE PHO_PREVNT(NPART)
33913 C**********************************************************************
33914 C
33915 C     print all information of event generation and history
33916 C
33917 C     input:        NPART  -1   minimal output: process IDs
33918 C                           0   additional output of /POEVT1/
33919 C                           1   additional output of /POSTRG/
33920 C                           2   additional output of /HEPEVT/
33921 C                               (call LULIST(1))
33922 C
33923 C**********************************************************************
33924       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33925       SAVE
33926
33927 C  input/output channels
33928       INTEGER LI,LO
33929       COMMON /POINOU/ LI,LO
33930 C  event debugging information
33931       INTEGER NMAXD
33932       PARAMETER (NMAXD=100)
33933       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33934      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33935       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33936      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33937 C  model switches and parameters
33938       CHARACTER*8 MDLNA
33939       INTEGER ISWMDL,IPAMDL
33940       DOUBLE PRECISION PARMDL
33941       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33942 C  global event kinematics and particle IDs
33943       INTEGER IFPAP,IFPAB
33944       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33945       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33946 C  general process information
33947       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33948       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33949
33950 C  standard particle data interface
33951       INTEGER NMXHEP
33952
33953       PARAMETER (NMXHEP=4000)
33954
33955       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33956       DOUBLE PRECISION PHEP,VHEP
33957       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33958      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33959      &                VHEP(4,NMXHEP)
33960 C  extension to standard particle data interface (PHOJET specific)
33961       INTEGER IMPART,IPHIST,ICOLOR
33962       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33963
33964 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
33965       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33966       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33967       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33968      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33969
33970       CHARACTER*15 PHO_PNAME
33971
33972       IF(NPART.GE.0) WRITE(LO,'(/)')
33973       WRITE(LO,'(1X,A,1PE10.3)')
33974      &  'PHO_PREVNT: c.m. energy',ECM
33975       CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33976       WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33977      &  'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33978      &  'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33979      &  KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33980      &  KHDPO
33981       WRITE(LO,'(6X,A,I4,4I3)')
33982      &  'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33983      &  IDIFR2,IDDPOM
33984
33985       IF(IPAMDL(13).GT.0) THEN
33986         WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33987         WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33988      &    ECMN,PCMN,SECM,SPCM
33989         WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33990       ENDIF
33991
33992       IF(NPART.LT.0) RETURN
33993
33994       IF(NPART.GE.1) CALL PHO_PRSTRG
33995
33996       WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33997       ICHAS  = 0
33998       IBARFS = 0
33999       IMULC  = 0
34000       IMUL   = 0
34001       WRITE(LO,'(/1X,A,A,/,1X,A,A)')
34002      &  '   NO  IST    NAME         MO-1 MO-2 DA-1 DA-2  CHA  BAR',
34003      &  '  IH1  IH2  CO1  CO2',
34004      &  '========================================================',
34005      &  '===================='
34006       DO 20 IH=1,NHEP
34007         CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
34008         BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
34009         WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
34010      &    IH,ISTHEP(IH),PHO_PNAME(IH,2),
34011      &    JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
34012      &    CH,BA,IPHIST(1,IH),IPHIST(2,IH),
34013      &    ICOLOR(1,IH),ICOLOR(2,IH)
34014         IF(ABS(ISTHEP(IH)).EQ.1) THEN
34015           ICHAS  = ICHAS  + IPHO_CHR3(IH,2)
34016           IBARFS = IBARFS + IPHO_BAR3(IH,2)
34017         ENDIF
34018         IF(ABS(ISTHEP(IH)).EQ.1) THEN
34019           IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
34020           IMUL = IMUL+1
34021         ENDIF
34022    20 CONTINUE
34023       WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
34024      &  'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
34025
34026       WRITE(LO,7)
34027       PXS    = 0.D0
34028       PYS    = 0.D0
34029       PZS    = 0.D0
34030       P0S    = 0.D0
34031       DO 30 IN=1,NHEP
34032         IF(     (ABS(PHEP(3,IN)).LT.99999.D0)
34033      &     .AND.(PHEP(4,IN).LT.99999.D0)) THEN
34034           WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
34035      &      (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
34036         ELSE
34037           WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
34038      &      (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
34039         ENDIF
34040         IF(ABS(ISTHEP(IN)).EQ.1) THEN
34041           PXS = PXS + PHEP(1,IN)
34042           PYS = PYS + PHEP(2,IN)
34043           PZS = PZS + PHEP(3,IN)
34044           P0S = P0S + PHEP(4,IN)
34045         ENDIF
34046    30 CONTINUE
34047       AMFS = P0S**2-PXS**2-PYS**2-PZS**2
34048       AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
34049       IF(P0S.LT.99999.D0) THEN
34050         WRITE(LO,10) '      sum:    ',PXS,PYS,PZS,P0S,AMFS
34051       ELSE
34052         WRITE(LO,12) '      sum:    ',PXS,PYS,PZS,P0S,AMFS
34053       ENDIF
34054       WRITE(LO,'(//)')
34055
34056     5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
34057      &  8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
34058      &  8H CHARGE ,8H BARYON ,/)
34059     6 FORMAT(7I8,2F8.3)
34060     7 FORMAT(/,2X,' NR STAT NAME        X-MOMENTA',
34061      &  ' Y-MOMENTA Z-MOMENTA  ENERGY    MASS     PT',/,
34062      &         2X,'-------------------------------',
34063      &  '--------------------------------------------')
34064     8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
34065     9 FORMAT(I10,14X,5F10.3)
34066    10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
34067    11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
34068    12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
34069
34070       IF(NPART.GE.2) CALL PYLIST(1)
34071
34072       END
34073
34074 *$ CREATE PHO_LTRHEP.FOR
34075 *COPY PHO_LTRHEP
34076 CDECK  ID>, PHO_LTRHEP
34077       SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
34078 C*******************************************************************
34079 C
34080 C     Lorentz transformation of entries I1 to I2 in /POEVT1/
34081 C
34082 C********************************************************************
34083       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34084       SAVE
34085
34086       PARAMETER ( DIFF = 0.001D0,
34087      &            EPS  = 1.D-5 )
34088
34089 C  input/output channels
34090       INTEGER LI,LO
34091       COMMON /POINOU/ LI,LO
34092 C  event debugging information
34093       INTEGER NMAXD
34094       PARAMETER (NMAXD=100)
34095       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34096      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34097       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34098      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34099
34100 C  standard particle data interface
34101       INTEGER NMXHEP
34102
34103       PARAMETER (NMXHEP=4000)
34104
34105       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
34106       DOUBLE PRECISION PHEP,VHEP
34107       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
34108      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
34109      &                VHEP(4,NMXHEP)
34110 C  extension to standard particle data interface (PHOJET specific)
34111       INTEGER IMPART,IPHIST,ICOLOR
34112       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
34113
34114       DO 100 I=I1,MIN(I2,NHEP)
34115         IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
34116           CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
34117      &      XX,YY,ZZ)
34118           EE=PHEP(4,I)
34119           CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
34120      &      PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
34121         ELSE IF(ISTHEP(I).EQ.20) THEN
34122           EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
34123           CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
34124      &      XX,YY,ZZ)
34125           CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
34126      &      PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
34127         ENDIF
34128  100  CONTINUE
34129
34130 C  debug precision
34131       IF(IDEB(70).LT.1) RETURN
34132       DO 200 I=I1,MIN(NHEP,I2)
34133         IF(ABS(ISTHEP(I)).GT.10) GOTO 190
34134         PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
34135         PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
34136         IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
34137           WRITE(LO,'(1X,A,I5,2E13.4)')
34138      &      'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
34139         ENDIF
34140  190    CONTINUE
34141  200  CONTINUE
34142
34143       END
34144
34145 *$ CREATE PHO_PECMS.FOR
34146 *COPY PHO_PECMS
34147 CDECK  ID>, PHO_PECMS
34148       SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
34149 C*******************************************************************
34150 C
34151 C     calculation of cms momentum and energy of massive particle
34152 C     (ID=  1 using PMASS1,  2 using PMASS2)
34153 C
34154 C     output:  PP    cms momentum
34155 C              EE    energy in CMS of particle ID
34156 C
34157 C********************************************************************
34158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34159       SAVE
34160
34161 C  input/output channels
34162       INTEGER LI,LO
34163       COMMON /POINOU/ LI,LO
34164 C  event debugging information
34165       INTEGER NMAXD
34166       PARAMETER (NMAXD=100)
34167       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34168      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34169       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34170      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34171 C  some constants
34172       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
34173       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
34174      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
34175
34176       S=ECM**2
34177       PM1 = SIGN(PMASS1**2,PMASS1)
34178       PM2 = SIGN(PMASS2**2,PMASS2)
34179       PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
34180      &          + PM1**2 + PM2**2)/(2.D0*ECM)
34181
34182       IF(ID.EQ.1) THEN
34183         EE = SQRT( PM1 + PP**2 )
34184       ELSE IF(ID.EQ.2) THEN
34185         EE = SQRT( PM2 + PP**2 )
34186       ELSE
34187         WRITE(LO,'(/1X,A,I3,/)')
34188      &    'PHO_PECMS:ERROR: invalid ID number:',ID
34189         EE = PP
34190       ENDIF
34191
34192       END
34193
34194 *$ CREATE PHO_FRAINI.FOR
34195 *COPY PHO_FRAINI
34196 CDECK  ID>, PHO_FRAINI
34197       SUBROUTINE PHO_FRAINI(IDEFAU)
34198 C***********************************************************************
34199 C
34200 C     initialization of fragmentation packages
34201 C      (currently LUND JETSET)
34202 C
34203 C     initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
34204 C                      changed to work in PHOJET   (R.E. 1/94)
34205 C
34206 C     input:  IDEFAU    0  no hadronization at all
34207 C                       1  do not touch any parameter of JETSET
34208 C                       2  default parameters kept, decay length 10mm to
34209 C                          define stable particles
34210 C                       3  load tuned parameters for JETSET 7.3
34211 C             neg. value:  prevent strange/charm hadrons from decaying
34212 C
34213 C***********************************************************************
34214       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34215       SAVE
34216
34217       PARAMETER (EPS=1.D-10)
34218
34219 C  input/output channels
34220       INTEGER LI,LO
34221       COMMON /POINOU/ LI,LO
34222
34223       INTEGER N,NPAD,K
34224       DOUBLE PRECISION P,V
34225       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
34226
34227       INTEGER MSTU,MSTJ
34228       DOUBLE PRECISION PARU,PARJ
34229       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34230
34231       INTEGER KCHG
34232       DOUBLE PRECISION  PMAS,PARF,VCKM
34233       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34234
34235       INTEGER MDCY,MDME,KFDP
34236       DOUBLE PRECISION  BRAT
34237       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
34238
34239       INTEGER PYCOMP
34240
34241       IDEFAB = ABS(IDEFAU)
34242
34243       IF(IDEFAB.EQ.0) THEN
34244         WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
34245         RETURN
34246       ENDIF
34247 C  defaults
34248       DEF2  = PARJ(2)
34249       IDEF12 = MSTJ(12)
34250       DEF19 = PARJ(19)
34251       DEF41 = PARJ(41)
34252       DEF42 = PARJ(42)
34253       DEF21 = PARJ(21)
34254
34255 C  declare stable particles
34256       IF(IDEFAB.GE.2) MSTJ(22) = 2
34257
34258 C  load optimized parameters
34259       IF(IDEFAB.GE.3) THEN
34260
34261 *       PARJ(19)=0.19
34262 C  Lund a-parameter
34263 C  (default=0.3)
34264         PARJ(41)=0.3
34265 C  Lund b-parameter
34266 C  (default=1.0)
34267         PARJ(42)=1.0
34268 C  Lund sigma parameter in pt distribution
34269 C  (default=0.36)
34270         PARJ(21)=0.36
34271       ENDIF
34272 C
34273 C  prevent particles decaying
34274       IF(IDEFAU.LT.0) THEN
34275 C                 K0S
34276
34277         KC=PYCOMP(310)
34278
34279         MDCY(KC,1)=0
34280 C                 PI0
34281
34282         KC=PYCOMP(111)
34283
34284         MDCY(KC,1)=0
34285 C                 LAMBDA
34286
34287         KC=PYCOMP(3122)
34288
34289         MDCY(KC,1)=0
34290 C                 ALAMBDA
34291
34292         KC=PYCOMP(-3122)
34293
34294         MDCY(KC,1)=0
34295 C                 SIG+
34296
34297         KC=PYCOMP(3222)
34298
34299         MDCY(KC,1)=0
34300 C                 ASIG+
34301
34302         KC=PYCOMP(-3222)
34303
34304         MDCY(KC,1)=0
34305 C                 SIG-
34306
34307         KC=PYCOMP(3112)
34308
34309         MDCY(KC,1)=0
34310 C                 ASIG-
34311
34312         KC=PYCOMP(-3112)
34313
34314         MDCY(KC,1)=0
34315 C                 SIG0
34316
34317         KC=PYCOMP(3212)
34318
34319         MDCY(KC,1)=0
34320 C                 ASIG0
34321
34322         KC=PYCOMP(-3212)
34323
34324         MDCY(KC,1)=0
34325 C                 TET0
34326
34327         KC=PYCOMP(3322)
34328
34329         MDCY(KC,1)=0
34330 C                 ATET0
34331
34332         KC=PYCOMP(-3322)
34333
34334         MDCY(KC,1)=0
34335 C                 TET-
34336
34337         KC=PYCOMP(3312)
34338
34339         MDCY(KC,1)=0
34340 C                 ATET-
34341
34342         KC=PYCOMP(-3312)
34343
34344         MDCY(KC,1)=0
34345 C                 OMEGA-
34346
34347         KC=PYCOMP(3334)
34348
34349         MDCY(KC,1)=0
34350 C                 AOMEGA-
34351
34352         KC=PYCOMP(-3334)
34353
34354         MDCY(KC,1)=0
34355 C                 D+
34356
34357         KC=PYCOMP(411)
34358
34359         MDCY(KC,1)=0
34360 C                 D-
34361
34362         KC=PYCOMP(-411)
34363
34364         MDCY(KC,1)=0
34365 C                 D0
34366
34367         KC=PYCOMP(421)
34368
34369         MDCY(KC,1)=0
34370 C                 A-D0
34371
34372         KC=PYCOMP(-421)
34373
34374         MDCY(KC,1)=0
34375 C                 DS+
34376
34377         KC=PYCOMP(431)
34378
34379         MDCY(KC,1)=0
34380 C                 A-DS+
34381
34382         KC=PYCOMP(-431)
34383
34384         MDCY(KC,1)=0
34385 C                ETAC
34386
34387         KC=PYCOMP(441)
34388
34389         MDCY(KC,1)=0
34390 C                LAMBDAC+
34391
34392         KC=PYCOMP(4122)
34393
34394         MDCY(KC,1)=0
34395 C                A-LAMBDAC+
34396
34397         KC=PYCOMP(-4122)
34398
34399         MDCY(KC,1)=0
34400 C                SIGMAC++
34401
34402         KC=PYCOMP(4222)
34403
34404         MDCY(KC,1)=0
34405 C                SIGMAC+
34406
34407         KC=PYCOMP(4212)
34408
34409         MDCY(KC,1)=0
34410 C                SIGMAC0
34411
34412         KC=PYCOMP(4112)
34413
34414         MDCY(KC,1)=0
34415 C                A-SIGMAC++
34416
34417         KC=PYCOMP(-4222)
34418
34419         MDCY(KC,1)=0
34420 C                A-SIGMAC+
34421
34422         KC=PYCOMP(-4212)
34423
34424         MDCY(KC,1)=0
34425 C                A-SIGMAC0
34426
34427         KC=PYCOMP(-4112)
34428
34429         MDCY(KC,1)=0
34430 C                KSIC+
34431
34432         KC=PYCOMP(4232)
34433
34434         MDCY(KC,1)=0
34435 C                KSIC0
34436
34437         KC=PYCOMP(4132)
34438
34439         MDCY(KC,1)=0
34440 C                A-KSIC+
34441
34442         KC=PYCOMP(-4232)
34443
34444         MDCY(KC,1)=0
34445 C                A-KSIC0
34446
34447         KC=PYCOMP(-4132)
34448
34449         MDCY(KC,1)=0
34450       ENDIF
34451
34452       WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34453      &  DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34454  2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34455      &        ' --------------------------------------------------',/,
34456      & 5X,'parameter description               default / current',/,
34457      & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34458      & 5X,'MSTJ(12) popcorn                 : ',2I7,/,
34459      & 5X,'PARJ(19) popcorn                 : ',2F7.3,/,
34460      & 5X,'PARJ(41) Lund a                  : ',2F7.3,/,
34461      & 5X,'PARJ(42) Lund b                  : ',2F7.3,/,
34462      & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34463
34464       END
34465
34466 *$ CREATE PHO_SETPAR.FOR
34467 *COPY PHO_SETPAR
34468 CDECK  ID>, PHO_SETPAR
34469       SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34470 C**********************************************************************
34471 C
34472 C     assign a particle to either side 1 or 2
34473 C     (including special treatment for remnants)
34474 C
34475 C     input:    Iside      1,2  side selected for the particle
34476 C                          -2   output of current settings
34477 C               IDpdg      PDG number
34478 C               IDcpc      CPC number
34479 C                          0     CPC determination in subroutine
34480 C                          -1    special particle remnant, IDPDG
34481 C                                is the particle number the remnant
34482 C                                corresponds to (see /POHDFL/)
34483 C
34484 C**********************************************************************
34485
34486       IMPLICIT NONE
34487
34488       SAVE
34489
34490       integer Iside,IDpdg,IDcpc
34491       double precision Pvir
34492
34493 C  input/output channels
34494       INTEGER LI,LO
34495       COMMON /POINOU/ LI,LO
34496 C  event debugging information
34497       INTEGER NMAXD
34498       PARAMETER (NMAXD=100)
34499       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34500      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34501       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34502      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34503 C  global event kinematics and particle IDs
34504       INTEGER IFPAP,IFPAB
34505       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34506       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34507 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
34508       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34509       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34510       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34511      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34512 C  particle ID translation table
34513       integer         ID_pdg_list,ID_list,ID_pdg_max
34514       character*12    name_list
34515       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34516      &                ID_pdg_max
34517 C  general particle data
34518       double precision xm_list,tau_list,gam_list,
34519      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34520      &  xm_bb82_list,xm_bb102_list
34521       integer          ich3_list,iba3_list,iq_list,
34522      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
34523       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34524      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
34525      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34526      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34527      &  ich3_list(300),iba3_list(300),iq_list(3,300),
34528      &  id_psm_list(6,6),id_vem_list(6,6),
34529      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
34530 C  particle decay data
34531       double precision wg_sec_list
34532       integer          idec_list,isec_list
34533       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34534      &  isec_list(3,500)
34535
34536 C  external functions
34537       integer ipho_pdg2id,ipho_chr3,ipho_bar3
34538       double precision pho_pmass
34539
34540 C  local variables
34541       integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34542
34543       IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34544         IDcpcN = IDcpc
34545 C  remnant?
34546         IF(IDcpc.EQ.-1) THEN
34547           IF(Iside.EQ.1) THEN
34548             IDpdgR = 81
34549           ELSE
34550             IDpdgR = 82
34551           ENDIF
34552           IDcpcR = ipho_pdg2id(IDpdgR)
34553           IDEQB(Iside) = ipho_pdg2id(IDpdg)
34554           IDEQP(Iside) = IDpdg
34555 C  copy particle properties
34556           IDB = abs(IDEQB(Iside))
34557           xm_list(IDcpcR)  = xm_list(IDB)
34558           tau_list(IDcpcR) = tau_list(IDB)
34559           gam_list(IDcpcR) = gam_list(IDB)
34560           IF(IHFLS(Iside).EQ.1) THEN
34561             ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34562             iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34563           ELSE
34564             ich3_list(IDcpcR) = 0
34565             iba3_list(IDcpcR) = 0
34566           ENDIF
34567 C  quark content
34568           IFL1 = IHFLD(Iside,1)
34569           IFL2 = IHFLD(Iside,2)
34570           IFL3 = 0
34571           IF(IHFLS(Iside).EQ.1) THEN
34572             IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34573               IFL1 = IHFLD(Iside,1)/1000
34574               IFL2 = MOD(IHFLD(Iside,1)/100,10)
34575               IFL3 = IHFLD(Iside,2)
34576             ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34577               IFL1 = IHFLD(Iside,1)
34578               IFL2 = IHFLD(Iside,2)/1000
34579               IFL3 = MOD(IHFLD(Iside,2)/100,10)
34580             ENDIF
34581           ENDIF
34582           iq_list(1,IDcpcR) = IFL1
34583           iq_list(2,IDcpcR) = IFL2
34584           iq_list(3,IDcpcR) = IFL3
34585
34586           IDcpcN = IDcpcR
34587           IDPDGN = IDPDGR
34588
34589           IF(IDEB(87).GE.5) THEN
34590             WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34591      &        'pho_setpar: remnant assignment side',Iside,
34592      &        'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34593           ENDIF
34594         ELSE IF(IDcpc.EQ.0) THEN
34595 C  ordinary hadron
34596           IHFLS(Iside) = 1
34597           IHFLD(Iside,1) = 0
34598           IHFLD(Iside,2) = 0
34599           IDcpcN = ipho_pdg2id(IDpdg)
34600           IDpdgN = IDpdg
34601         ENDIF
34602
34603 C initialize /POGCMS/
34604         IFPAP(Iside) = IDpdgN
34605         IFPAB(Iside) = IDcpcN
34606         PMASS(Iside) = pho_pmass(IDcpcN,0)
34607         IF(IFPAP(Iside).EQ.22) THEN
34608           PVIRT(Iside) = ABS(PVIR)
34609         ELSE
34610           PVIRT(Iside) = 0.D0
34611         ENDIF
34612
34613       ELSE IF(Iside.EQ.-2) THEN
34614 C  output of current settings
34615         DO 100 I=1,2
34616           WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34617      &      'PHO_SETPAR: side',
34618      &      I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34619      &      PVIRT(I)
34620           IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34621             WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34622      &        'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34623      &        IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34624           ENDIF
34625  100    CONTINUE
34626       ELSE
34627         WRITE(LO,'(/1X,A,I8)')
34628      &    'pho_setpar: invalid argument (Iside)',Iside
34629       ENDIF
34630
34631       END
34632
34633 *$ CREATE PHO_XLAM.FOR
34634 *COPY PHO_XLAM
34635 CDECK  ID>, PHO_XLAM
34636       DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34637 C**********************************************************************
34638 C
34639 C     auxiliary function for two/three particle decay mode
34640 C     (standard LAMBDA**(1/2) function)
34641 C
34642 C**********************************************************************
34643       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34644       SAVE
34645 C
34646       YZ=Y-Z
34647       XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34648       IF(XLAM.LT.0.D0) XLAM=-XLAM
34649       PHO_XLAM=SQRT(XLAM)
34650       END
34651
34652 *$ CREATE PHO_BESSJ0.FOR
34653 *COPY PHO_BESSJ0
34654 CDECK  ID>, PHO_BESSJ0
34655       DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34656 C**********************************************************************
34657 C
34658 C     CERN (KERN) LIB function C312
34659 C
34660 C     modified by R. Engel (03/02/93)
34661 C
34662 C**********************************************************************
34663       DOUBLE PRECISION DX
34664       DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34665       DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34666       SAVE
34667
34668       DATA EIGHT /8.0D0/
34669       DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34670
34671       DATA C1( 0) /+0.15772 79714 7489D0/
34672       DATA C1( 1) /-0.00872 34423 5285D0/
34673       DATA C1( 2) /+0.26517 86132 0334D0/
34674       DATA C1( 3) /-0.37009 49938 7265D0/
34675       DATA C1( 4) /+0.15806 71023 3210D0/
34676       DATA C1( 5) /-0.03489 37694 1141D0/
34677       DATA C1( 6) /+0.00481 91800 6947D0/
34678       DATA C1( 7) /-0.00046 06261 6621D0/
34679       DATA C1( 8) /+0.00003 24603 2882D0/
34680       DATA C1( 9) /-0.00000 17619 4691D0/
34681       DATA C1(10) /+0.00000 00760 8164D0/
34682       DATA C1(11) /-0.00000 00026 7925D0/
34683       DATA C1(12) /+0.00000 00000 7849D0/
34684       DATA C1(13) /-0.00000 00000 0194D0/
34685       DATA C1(14) /+0.00000 00000 0004D0/
34686
34687       DATA C2( 0) /+0.99946 03493 4752D0/
34688       DATA C2( 1) /-0.00053 65220 4681D0/
34689       DATA C2( 2) /+0.00000 30751 8479D0/
34690       DATA C2( 3) /-0.00000 00517 0595D0/
34691       DATA C2( 4) /+0.00000 00016 3065D0/
34692       DATA C2( 5) /-0.00000 00000 7864D0/
34693       DATA C2( 6) /+0.00000 00000 0517D0/
34694       DATA C2( 7) /-0.00000 00000 0043D0/
34695       DATA C2( 8) /+0.00000 00000 0004D0/
34696       DATA C2( 9) /-0.00000 00000 0001D0/
34697
34698       DATA C3( 0) /-0.01555 58546 05337D0/
34699       DATA C3( 1) /+0.00006 83851 99426D0/
34700       DATA C3( 2) /-0.00000 07414 49841D0/
34701       DATA C3( 3) /+0.00000 00179 72457D0/
34702       DATA C3( 4) /-0.00000 00007 27192D0/
34703       DATA C3( 5) /+0.00000 00000 42201D0/
34704       DATA C3( 6) /-0.00000 00000 03207D0/
34705       DATA C3( 7) /+0.00000 00000 00301D0/
34706       DATA C3( 8) /-0.00000 00000 00033D0/
34707       DATA C3( 9) /+0.00000 00000 00004D0/
34708       DATA C3(10) /-0.00000 00000 00001D0/
34709
34710       X=DX
34711       V=ABS(X)
34712       IF(V .LT. EIGHT) THEN
34713        Y=V/EIGHT
34714        H=2.D0*Y**2-1.D0
34715        ALFA=-2.D0*H
34716        B1=0.D0
34717        B2=0.D0
34718        DO 1 I = 14,0,-1
34719        B0=C1(I)-ALFA*B1-B2
34720        B2=B1
34721     1  B1=B0
34722        B1=B0-H*B2
34723       ELSE
34724        R=1.D0/V
34725        Y=EIGHT*R
34726        H=2.D0*Y**2-1.D0
34727        ALFA=-2.D0*H
34728        B1=0.D0
34729        B2=0.D0
34730        DO 2 I = 9,0,-1
34731        B0=C2(I)-ALFA*B1-B2
34732        B2=B1
34733     2  B1=B0
34734        P=B0-H*B2
34735        B1=0.D0
34736        B2=0.D0
34737        DO 3 I = 10,0,-1
34738        B0=C3(I)-ALFA*B1-B2
34739        B2=B1
34740     3  B1=B0
34741        Q=Y*(B0-H*B2)
34742        B0=V-PI2
34743        B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34744       ENDIF
34745       PHO_BESSJ0=B1
34746       RETURN
34747       END
34748
34749 *$ CREATE PHO_BESSI0.FOR
34750 *COPY PHO_BESSI0
34751 CDECK  ID>, PHO_BESSI0
34752       DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34753 C**********************************************************************
34754 C
34755 C      Bessel Function I0
34756 C
34757 C**********************************************************************
34758       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34759       SAVE
34760
34761       AX = ABS(X)
34762       IF (AX .LT. 3.75D0) THEN
34763         Y = (X/3.75D0)**2
34764         PHO_BESSI0 =
34765      &    1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34766      &    +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34767       ELSE
34768         Y = 3.75D0/AX
34769         PHO_BESSI0 =
34770      &    (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34771      &    +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34772      &    +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34773      &    +Y*0.392377D-2))))))))
34774       ENDIF
34775
34776       END
34777
34778 *$ CREATE PHO_BESSI1.FOR
34779 *COPY PHO_BESSI1
34780 CDECK  ID>, PHO_BESSI1
34781       DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34782 C**********************************************************************
34783 C
34784 C      Bessel Function I1
34785 C
34786 C**********************************************************************
34787       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34788       SAVE
34789
34790       AX = ABS(X)
34791
34792       IF (AX .LT. 3.75D0) THEN
34793         Y = (X/3.75D0)**2
34794         BESLI1 =
34795      &    AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34796      &    +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34797       ELSE
34798         Y = 3.75D0/AX
34799         BESLI1 =
34800      &    0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34801      &    -Y*0.420059D-2))
34802         BESLI1 =
34803      &    0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34804      &    +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34805         BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34806       ENDIF
34807       IF (X .LT. 0.D0) BESLI1 = -BESLI1
34808
34809       PHO_BESSI1 = BESLI1
34810
34811       END
34812
34813 *$ CREATE PHO_BESSK0.FOR
34814 *COPY PHO_BESSK0
34815 CDECK  ID>, PHO_BESSK0
34816       DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34817 C**********************************************************************
34818 C
34819 C      Modified Bessel Function K0
34820 C
34821 C**********************************************************************
34822       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34823       SAVE
34824
34825       IF (X .LT. 2.D0) THEN
34826         Y = X**2/4.D0
34827         PHO_BESSK0 =
34828      &    (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34829      &    +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34830      &    +Y*(0.10750D-3+Y*0.740D-5))))))
34831       ELSE
34832         Y = 2.D0/X
34833         PHO_BESSK0 =
34834      &    (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34835      &    +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34836      &    +Y*(-0.251540D-2+Y*0.53208D-3))))))
34837       ENDIF
34838
34839       END
34840
34841 *$ CREATE PHO_BESSK1.FOR
34842 *COPY PHO_BESSK1
34843 CDECK  ID>, PHO_BESSK1
34844       DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34845 C**********************************************************************
34846 C
34847 C      Modified Bessel Function K1
34848 C
34849 C**********************************************************************
34850       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34851       SAVE
34852
34853       IF (X .LT. 2.D0) THEN
34854         Y = X**2/4.D0
34855         PHO_BESSK1 =
34856      &    (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34857      &    +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34858      &    +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34859       ELSE
34860         Y=2.D0/X
34861         PHO_BESSK1 =
34862      &    (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34863      &    +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34864      &    +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34865       ENDIF
34866
34867       END
34868
34869 *$ CREATE PHO_GAUSET.FOR
34870 *COPY PHO_GAUSET
34871 CDECK  ID>, PHO_GAUSET
34872       SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34873 C********************************************************************
34874 C
34875 C     N-point gauss zeros and weights for the interval (AX,BX) are
34876 C           stored in  arrays Z and W respectively.
34877 C
34878 C*********************************************************************
34879       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34880       SAVE
34881
34882       COMMON /POGDAT/A(273),X(273),KTAB(96)
34883       DIMENSION Z(NX),W(NX)
34884
34885       ALPHA=0.5*(BX+AX)
34886       BETA=0.5*(BX-AX)
34887       N=NX
34888
34889 C  the N=1 case:
34890       IF(N.NE.1) GO TO 1
34891       Z(1)=ALPHA
34892       W(1)=BX-AX
34893       RETURN
34894
34895 C  the Gauss cases:
34896     1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34897       IF(N.EQ.20) GO TO 2
34898       IF(N.EQ.24) GO TO 2
34899       IF(N.EQ.32) GO TO 2
34900       IF(N.EQ.40) GO TO 2
34901       IF(N.EQ.48) GO TO 2
34902       IF(N.EQ.64) GO TO 2
34903       IF(N.EQ.80) GO TO 2
34904       IF(N.EQ.96) GO TO 2
34905
34906 C  the extended Gauss cases:
34907       IF((N/96)*96.EQ.N) GO TO 3
34908
34909 C  jump to center of intervall intrgration:
34910       GO TO 100
34911
34912 C  get Gauss point array
34913
34914     2 CALL PHO_GAUDAT
34915 C  extract real points
34916       K=KTAB(N)
34917       M=N/2
34918       DO 21 J=1,M
34919 C       extract values from big array
34920         JTAB=K-1+J
34921         WTEMP=BETA*A(JTAB)
34922         DELTA=BETA*X(JTAB)
34923 C       store them backward
34924         Z(J)=ALPHA-DELTA
34925         W(J)=WTEMP
34926 C       store them forward
34927         JP=N+1-J
34928         Z(JP)=ALPHA+DELTA
34929         W(JP)=WTEMP
34930    21 CONTINUE
34931 C     store central point (odd N)
34932       IF((N-M-M).EQ.0) RETURN
34933       Z(M+1)=ALPHA
34934       JMID=K+M
34935       W(M+1)=BETA*A(JMID)
34936       RETURN
34937
34938 C  get ND96 times chained 96 Gauss point array
34939
34940     3 CALL PHO_GAUDAT
34941 C  print out message
34942 C     -extract real points
34943       K=KTAB(96)
34944       ND96=N/96
34945       DO 31 J=1,48
34946 C       extract values from big array
34947         JTAB=K-1+J
34948         WTEMP=BETA*A(JTAB)
34949         DELTA=BETA*X(JTAB)
34950         WTeMP=WTEMP/ND96
34951         DeLTA=DELTA/ND96
34952         DO 32 JD96=0,ND96-1
34953           ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34954 C         store them backward
34955           Z(J+JD96*96)=ZCNTR-DELTA
34956           W(J+JD96*96)=WTEMP
34957 C         store them forward
34958           JP=96+1-J
34959           Z(JP+JD96*96)=ZCNTR+DELTA
34960           W(JP+JD96*96)=WTEMP
34961    32   CONTINUE
34962    31 CONTINUE
34963       RETURN
34964
34965 C  the center of intervall cases:
34966   100 CONTINUE
34967 C  put in constant weight and equally spaced central points
34968       N=IABS(N)
34969       DO 111 IN=1,N
34970         WIN=(BX-AX)/FLOAT(N)
34971         Z(IN)=AX  + (FLOAT(IN)-.5)*WIN
34972   111 W(IN)=WIN
34973
34974       END
34975
34976 *$ CREATE PHO_GAUDAT.FOR
34977 *COPY PHO_GAUDAT
34978 CDECK  ID>, PHO_GAUDAT
34979       SUBROUTINE PHO_GAUDAT
34980 C*********************************************************************
34981 C
34982 C     store big arrays needed for Gauss integral, CERNLIB D106BD
34983 C     (arrays A,X,ITAB copied on B,Y,LTAB)
34984 C
34985 C*********************************************************************
34986       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34987
34988       SAVE
34989       COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34990       DIMENSION       A(273),X(273),KTAB(96)
34991
34992 C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34993       DATA KTAB(2)/1/
34994       DATA KTAB(3)/2/
34995       DATA KTAB(4)/4/
34996       DATA KTAB(5)/6/
34997       DATA KTAB(6)/9/
34998       DATA KTAB(7)/12/
34999       DATA KTAB(8)/16/
35000       DATA KTAB(9)/20/
35001       DATA KTAB(10)/25/
35002       DATA KTAB(11)/30/
35003       DATA KTAB(12)/36/
35004       DATA KTAB(13)/42/
35005       DATA KTAB(14)/49/
35006       DATA KTAB(15)/56/
35007       DATA KTAB(16)/64/
35008       DATA KTAB(20)/72/
35009       DATA KTAB(24)/82/
35010       DATA KTAB(28)/82/
35011       DATA KTAB(32)/94/
35012       DATA KTAB(36)/94/
35013       DATA KTAB(40)/110/
35014       DATA KTAB(44)/110/
35015       DATA KTAB(48)/130/
35016       DATA KTAB(52)/130/
35017       DATA KTAB(56)/130/
35018       DATA KTAB(60)/130/
35019       DATA KTAB(64)/154/
35020       DATA KTAB(68)/154/
35021       DATA KTAB(72)/154/
35022       DATA KTAB(76)/154/
35023       DATA KTAB(80)/186/
35024       DATA KTAB(84)/186/
35025       DATA KTAB(88)/186/
35026       DATA KTAB(92)/186/
35027       DATA KTAB(96)/226/
35028 C
35029 C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
35030 C
35031 C-----N=2
35032       DATA X(1)/0.577350269189626D0  /, A(1)/1.000000000000000D0  /
35033 C-----N=3
35034       DATA X(2)/0.774596669241483D0  /, A(2)/0.555555555555556D0  /
35035       DATA X(3)/0.000000000000000D0  /, A(3)/0.888888888888889D0  /
35036 C-----N=4
35037       DATA X(4)/0.861136311594053D0  /, A(4)/0.347854845137454D0  /
35038       DATA X(5)/0.339981043584856D0  /, A(5)/0.652145154862546D0  /
35039 C-----N=5
35040       DATA X(6)/0.906179845938664D0  /, A(6)/0.236926885056189D0  /
35041       DATA X(7)/0.538469310105683D0  /, A(7)/0.478628670499366D0  /
35042       DATA X(8)/0.000000000000000D0  /, A(8)/0.568888888888889D0  /
35043 C-----N=6
35044       DATA X(9)/0.932469514203152D0  /, A(9)/0.171324492379170D0  /
35045       DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
35046       DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
35047 C-----N=7
35048       DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
35049       DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
35050       DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
35051       DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
35052 C-----N=8
35053       DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
35054       DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
35055       DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
35056       DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
35057 C-----N=9
35058       DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
35059       DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
35060       DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
35061       DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
35062       DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
35063 C-----N=10
35064       DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
35065       DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
35066       DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
35067       DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
35068       DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
35069 C-----N=11
35070       DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
35071       DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
35072       DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
35073       DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
35074       DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
35075       DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
35076 C-----N=12
35077       DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
35078       DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
35079       DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
35080       DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
35081       DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
35082       DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
35083 C-----N=13
35084       DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
35085       DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
35086       DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
35087       DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
35088       DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
35089       DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
35090       DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
35091 C-----N=14
35092       DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
35093       DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
35094       DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
35095       DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
35096       DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
35097       DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
35098       DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
35099 C-----N=15
35100       DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
35101       DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
35102       DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
35103       DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
35104       DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
35105       DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
35106       DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
35107       DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
35108 C-----N=16
35109       DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
35110       DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
35111       DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
35112       DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
35113       DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
35114       DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
35115       DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
35116       DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
35117 C-----N=20
35118       DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
35119       DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
35120       DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
35121       DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
35122       DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
35123       DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
35124       DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
35125       DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
35126       DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
35127       DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
35128 C-----N=24
35129       DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
35130       DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
35131       DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
35132       DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
35133       DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
35134       DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
35135       DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
35136       DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
35137       DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
35138       DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
35139       DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
35140       DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
35141 C-----N=32
35142       DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
35143       DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
35144       DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
35145       DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
35146       DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
35147       DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
35148       DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
35149       DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
35150       DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
35151       DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
35152       DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
35153       DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
35154       DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
35155       DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
35156       DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
35157       DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
35158 C-----N=40
35159       DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
35160       DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
35161       DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
35162       DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
35163       DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
35164       DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
35165       DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
35166       DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
35167       DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
35168       DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
35169       DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
35170       DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
35171       DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
35172       DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
35173       DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
35174       DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
35175       DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
35176       DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
35177       DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
35178       DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
35179 C-----N=48
35180       DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
35181       DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
35182       DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
35183       DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
35184       DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
35185       DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
35186       DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
35187       DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
35188       DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
35189       DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
35190       DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
35191       DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
35192       DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
35193       DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
35194       DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
35195       DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
35196       DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
35197       DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
35198       DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
35199       DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
35200       DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
35201       DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
35202       DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
35203       DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
35204 C-----N=64
35205       DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
35206       DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
35207       DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
35208       DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
35209       DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
35210       DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
35211       DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
35212       DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
35213       DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
35214       DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
35215       DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
35216       DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
35217       DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
35218       DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
35219       DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
35220       DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
35221       DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
35222       DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
35223       DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
35224       DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
35225       DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
35226       DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
35227       DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
35228       DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
35229       DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
35230       DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
35231       DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
35232       DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
35233       DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
35234       DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
35235       DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
35236       DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
35237 C-----N=80
35238       DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
35239       DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
35240       DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
35241       DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
35242       DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
35243       DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
35244       DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
35245       DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
35246       DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
35247       DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
35248       DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
35249       DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
35250       DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
35251       DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
35252       DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
35253       DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
35254       DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
35255       DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
35256       DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
35257       DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
35258       DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
35259       DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
35260       DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
35261       DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
35262       DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
35263       DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
35264       DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
35265       DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
35266       DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
35267       DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
35268       DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
35269       DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
35270       DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
35271       DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
35272       DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
35273       DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
35274       DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
35275       DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
35276       DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
35277       DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
35278 C-----N=96
35279       DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
35280       DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
35281       DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
35282       DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
35283       DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
35284       DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
35285       DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
35286       DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
35287       DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
35288       DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
35289       DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
35290       DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
35291       DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
35292       DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
35293       DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
35294       DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
35295       DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
35296       DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
35297       DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
35298       DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
35299       DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
35300       DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
35301       DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
35302       DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
35303       DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
35304       DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
35305       DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
35306       DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
35307       DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
35308       DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
35309       DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
35310       DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
35311       DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
35312       DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
35313       DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
35314       DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
35315       DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
35316       DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
35317       DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
35318       DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
35319       DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
35320       DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
35321       DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
35322       DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
35323       DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
35324       DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
35325       DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
35326       DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
35327       DATA IBD/0/
35328       IF(IBD.NE.0) RETURN
35329       IBD=1
35330       DO 10 I=1,273
35331         B(I) = A(I)
35332         Y(I) = X(I)
35333  10   CONTINUE
35334       DO 20 I=1,96
35335         LTAB(I) = KTAB(I)
35336  20   CONTINUE
35337       END
35338
35339 *$ CREATE PHO_DZEROX.FOR
35340 *COPY PHO_DZEROX
35341 CDECK  ID>, PHO_DZEROX
35342       DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
35343 C**********************************************************************
35344 C
35345 C     Based on
35346 C
35347 C        J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
35348 C        Guaranteed Convergence for Finding a Zero of a Function,
35349 C        ACM Trans. Math. Software 1 (1975) 330-345.
35350 C
35351 C        (MODE = 1: Algorithm M;    MODE = 2: Algorithm R)
35352 C
35353 C        CERNLIB C200
35354 C
35355 C***********************************************************************
35356       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35357       SAVE
35358
35359 C  input/output channels
35360       INTEGER LI,LO
35361       COMMON /POINOU/ LI,LO
35362
35363       CHARACTER NAME*(*)
35364       PARAMETER (NAME = 'PHO_DZEROX')
35365       LOGICAL LMT
35366       DIMENSION IM1(2),IM2(2),LMT(2)
35367       EXTERNAL F
35368
35369       PARAMETER (Z1 = 1, HALF = Z1/2)
35370
35371       DATA IM1 /2,3/, IM2 /-1,3/
35372
35373       IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
35374        C=-2D+10
35375        WRITE(LO,100) NAME,MODE
35376        GO TO 99
35377       ENDIF
35378       FA=F(B0)
35379       FB=F(A0)
35380       IF(FA*FB .GT. 0) THEN
35381        C=-3D+10
35382        WRITE(LO,101) NAME
35383        GO TO 99
35384       ENDIF
35385       ATL=ABS(EPS)
35386       B=A0
35387       A=B0
35388       LMT(2)=.TRUE.
35389       MF=2
35390     1 C=A
35391       FC=FA
35392     2 IE=0
35393     3 IF(ABS(FC) .LT. ABS(FB)) THEN
35394        IF(C .NE. A) THEN
35395         D=A
35396         FD=FA
35397        END IF
35398        A=B
35399        B=C
35400        C=A
35401        FA=FB
35402        FB=FC
35403        FC=FA
35404       END IF
35405       TOL=ATL*(1+ABS(C))
35406       H=HALF*(C+B)
35407       HB=H-B
35408       IF(ABS(HB) .GT. TOL) THEN
35409        IF(IE .GT. IM1(MODE)) THEN
35410         W=HB
35411        ELSE
35412         TOL=TOL*SIGN(Z1,HB)
35413         P=(B-A)*FB
35414         LMT(1)=IE .LE. 1
35415         IF(LMT(MODE)) THEN
35416          Q=FA-FB
35417          LMT(2)=.FALSE.
35418         ELSE
35419          FDB=(FD-FB)/(D-B)
35420          FDA=(FD-FA)/(D-A)
35421          P=FDA*P
35422          Q=FDB*FA-FDA*FB
35423         END IF
35424         IF(P .LT. 0) THEN
35425          P=-P
35426          Q=-Q
35427         END IF
35428         IF(IE .EQ. IM2(MODE)) P=P+P
35429         IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
35430          W=TOL
35431         ELSEIF(P .LT. HB*Q) THEN
35432          W=P/Q
35433         ELSE
35434          W=HB
35435         END IF
35436        END IF
35437        D=A
35438        A=B
35439        FD=FA
35440        FA=FB
35441        B=B+W
35442        MF=MF+1
35443        IF(MF .GT. MAXF) THEN
35444         WRITE(LO,102) NAME
35445         GO TO 99
35446        ENDIF
35447        FB=F(B)
35448        IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35449        IF(W .EQ. HB) GO TO 2
35450        IE=IE+1
35451        GO TO 3
35452       END IF
35453    99 CONTINUE
35454       PHO_DZEROX=C
35455       RETURN
35456   100 FORMAT(1X,A,': mode = ',I3,' illegal')
35457   101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35458   102 FORMAT(1X,A,': too many function calls')
35459
35460       END
35461
35462 *$ CREATE PHO_EXPINT.FOR
35463 *COPY PHO_EXPINT
35464 CDECK  ID>, PHO_EXPINT
35465       DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35466 C***********************************************************************
35467 C
35468 C     function to calculate  E_i(x) = -E_1(-x)
35469 C
35470 C     based on CERNLIB C337   (changed by R.Engel 10/1993)
35471 C
35472 C***********************************************************************
35473       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35474       SAVE
35475
35476 C  input/output channels
35477       INTEGER LI,LO
35478       COMMON /POINOU/ LI,LO
35479
35480       DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35481       DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35482       DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35483
35484       DATA  X0 /0.37250 74107 8137D0/
35485       DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35486       DATA P1
35487      1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35488      2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35489      3 -4.34981 43832 952D+2/
35490       DATA Q1
35491      1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35492      2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35493      3 +7.53585 64359 843D+2/
35494       DATA P2
35495      1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35496      2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35497      3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35498      4 +4.65627 10797 510D-7/
35499       DATA Q2
35500      1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35501      2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35502      3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35503      4 +1.00000 00000 000D+0/
35504       DATA P3
35505      1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35506      2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35507      3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35508       DATA Q3
35509      1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35510      2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35511      3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35512       DATA P4
35513      1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35514      2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35515      3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35516      4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35517       DATA Q4
35518      1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35519      2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35520      3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35521      4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35522       DATA A1
35523      1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35524      2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35525      3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35526      4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35527       DATA B1
35528      1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35529      2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35530      3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35531      4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35532       DATA A2
35533      1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35534      2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35535      3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35536      4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35537       DATA B2
35538      1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35539      2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35540      3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35541      4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35542       DATA A3
35543      1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35544      2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35545      3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35546       DATA B3
35547      1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35548      2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35549      3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35550 C
35551 C  conversion to E_i function
35552       X = -RXM
35553 C
35554       IF(X .LE. XL(1)) THEN
35555        AP=A3(1)-X
35556        DO 1 I = 2,5
35557     1  AP=A3(I)-X+B3(I)/AP
35558        Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35559       ELSEIF(X .LE. XL(2)) THEN
35560        AP=A2(1)-X
35561        DO 2 I = 2,7
35562     2     AP=A2(I)-X+B2(I)/AP
35563        Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35564       ELSEIF(X .LE. XL(3)) THEN
35565        AP=A1(1)-X
35566        DO 3 I = 2,7
35567     3     AP=A1(I)-X+B1(I)/AP
35568        Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35569       ELSEIF(X .LT. XL(4)) THEN
35570        V=-2.D0*(X/3.D0+1.D0)
35571        BP=0.D0
35572        DP=P4(1)
35573        DO 4 I = 2,8
35574           AP=BP
35575           BP=DP
35576     4     DP=P4(I)-AP+V*BP
35577        BQ=0.D0
35578        DQ=Q4(1)
35579        DO 14 I = 2,8
35580           AQ=BQ
35581           BQ=DQ
35582    14     DQ=Q4(I)-AQ+V*BQ
35583        Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35584       ELSEIF(X .EQ. XL(4)) THEN
35585 *      CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35586 *      IF(MFLAG) THEN
35587 *       IF(LGFILE .EQ. 0) THEN
35588 *        WRITE(LO,100) ENAME
35589 *       ELSE
35590 *        WRITE(LGFILE,100) ENAME
35591 *       ENDIF
35592 *      ENDIF
35593 *      IF(.NOT.RFLAG) CALL ABEND
35594        PHO_EXPINT=0.D0
35595        RETURN
35596       ELSEIF(X .LT. XL(5)) THEN
35597        AP=P1(1)
35598        AQ=Q1(1)
35599        DO 5 I = 2,5
35600           AP=P1(I)+X*AP
35601     5     AQ=Q1(I)+X*AQ
35602        Y=-LOG(X)+AP/AQ
35603       ELSEIF(X .LE. XL(6)) THEN
35604        Y=1.D0/X
35605        AP=P2(1)
35606        AQ=Q2(1)
35607        DO 6 I = 2,7
35608           AP=P2(I)+Y*AP
35609     6     AQ=Q2(I)+Y*AQ
35610        Y=EXP(-X)*AP/AQ
35611       ELSE
35612        Y=1.D0/X
35613        AP=P3(1)
35614        AQ=Q3(1)
35615        DO 7 I = 2,6
35616           AP=P3(I)+Y*AP
35617     7     AQ=Q3(I)+Y*AQ
35618        Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35619       ENDIF
35620 C  sign conversion to E_i
35621       PHO_EXPINT=-Y
35622
35623       END
35624
35625 *$ CREATE PHO_RNDBET.FOR
35626 *COPY PHO_RNDBET
35627 CDECK  ID>, PHO_RNDBET
35628       DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35629 C********************************************************************
35630 C
35631 C     RANDOM NUMBER GENERATION FROM BETA
35632 C     DISTRIBUTION IN REGION  0 < X < 1.
35633 C     F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35634 C                                                        *GAMM(ETA))
35635 C
35636 C********************************************************************
35637       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35638       SAVE
35639
35640       Y = PHO_RNDGAM(1.D0,GAM)
35641       Z = PHO_RNDGAM(1.D0,ETA)
35642
35643       PHO_RNDBET = Y/(Y+Z)
35644
35645       END
35646
35647 *$ CREATE PHO_RNDGAM.FOR
35648 *COPY PHO_RNDGAM
35649 CDECK  ID>, PHO_RNDGAM
35650       DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35651 C********************************************************************
35652 C
35653 C     RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35654 C     F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35655 C
35656 C********************************************************************
35657       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35658       SAVE
35659 C
35660       NCOU=0
35661       N = ETA
35662       F = ETA - N
35663       IF(F.EQ.0.D0) GOTO 20
35664    10 R = DT_RNDM(ETA)
35665       NCOU=NCOU+1
35666       IF (NCOU.GE.11) GOTO 20
35667       IF(R.LT.F/(F+2.71828D0)) GOTO 30
35668       YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35669       IF(ABS(YYY).GT.50.D0) GOTO 20
35670       Y = EXP(YYY)
35671       IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35672       GOTO 40
35673    20 Y = 0.D0
35674       GOTO 50
35675    30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35676       IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35677    40 IF(N.EQ.0) GOTO 70
35678    50 Z = 1.D0
35679       DO 60 I = 1,N
35680    60 Z = Z*DT_RNDM(Y)
35681       Y = Y-LOG(Z+1.0D-9)
35682    70 PHO_RNDGAM = Y/ALAM
35683       RETURN
35684       END
35685
35686 *$ CREATE PHO_SFECFE.FOR
35687 *COPY PHO_SFECFE
35688 CDECK  ID>, PHO_SFECFE
35689       SUBROUTINE PHO_SFECFE(SFE,CFE)
35690 C**********************************************************************
35691 C
35692 C     fast random SIN(X) COS(X) selection
35693 C
35694 C**********************************************************************
35695       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35696       SAVE
35697 C
35698     1 CONTINUE
35699         X=DT_RNDM(XX)
35700         Y=DT_RNDM(YY)
35701         XX=X*X
35702         YY=Y*Y
35703         XY=XX+YY
35704       IF(XY.GT.1.D0) GOTO 1
35705       CFE=(XX-YY)/XY
35706       SFE=2.D0*X*Y/XY
35707       IF(DT_RNDM(XY).LT.0.5D0) THEN
35708         SFE=-SFE
35709       ENDIF
35710       END
35711
35712 *$ CREATE PHO_SWAPD.FOR
35713 *COPY PHO_SWAPD
35714 CDECK  ID>, PHO_SWAPD
35715       SUBROUTINE PHO_SWAPD(D1,D2)
35716 C********************************************************************
35717 C
35718 C     exchange of argument values (double precision)
35719 C
35720 C********************************************************************
35721       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35722       D = D1
35723       D1 = D2
35724       D2 = D
35725       END
35726
35727 *$ CREATE PHO_SWAPI.FOR
35728 *COPY PHO_SWAPI
35729 CDECK  ID>, PHO_SWAPI
35730       SUBROUTINE PHO_SWAPI(I1,I2)
35731 C********************************************************************
35732 C
35733 C     exchange of argument values (integer)
35734 C
35735 C********************************************************************
35736       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35737       K = I1
35738       I1 = I2
35739       I2 = K
35740       END
35741
35742 *$ CREATE PHO_HADCSL.FOR
35743 *COPY PHO_HADCSL
35744 CDECK  ID>, PHO_HADCSL
35745       SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35746      &                     SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35747 C***********************************************************************
35748 C
35749 C     low-energy cross section parametrizations
35750 C
35751 C     input:   ID1,ID2     PDG IDs of particles (meson first)
35752 C              ECM         c.m. energy (GeV)
35753 C              PLAB        lab. momentum (second particle at rest)
35754 C              IMODE       1    ECM given, PLAB ignored
35755 C                          2    PLAB given, ECM ignored
35756 C
35757 C     output:  SIGTOT      total cross section (mb)
35758 C              SIGEL       elastic cross section (mb)
35759 C              SIGDIF      diffracive cross section (sd-1,sd-2,dd), (mb)
35760 C              SLOPE       forward elastic slope (GeV**-2)
35761 C              RHO         real/imaginary part of elastic amplitude
35762 C
35763 C     comments:
35764 C
35765 C     - low-energy data interpolation uses PDG fits from 1992 issue
35766 C     - high-energy extrapolation by Donnachie-Landshoff like fit made
35767 C       by PDG 1996
35768 C     - analytic extension of amplitude to calculate rho
35769 C
35770 C***********************************************************************
35771
35772       IMPLICIT NONE
35773
35774       SAVE
35775
35776       INTEGER ID1,ID2,IMODE
35777       DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35778
35779 C  input/output channels
35780       INTEGER LI,LO
35781       COMMON /POINOU/ LI,LO
35782 C  some constants
35783       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35784       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35785      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35786 C  model switches and parameters
35787       CHARACTER*8 MDLNA
35788       INTEGER ISWMDL,IPAMDL
35789       DOUBLE PRECISION PARMDL
35790       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35791
35792       INTEGER K
35793       DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35794      &  SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35795
35796       DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35797
35798       DATA TPDG92  /
35799      &  3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35800      &  3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35801      &  5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35802      &  5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35803      &  4.D0, 340.D0,  16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35804      &  4.D0, 340.D0,  0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35805      &  2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35806      &  2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35807      &  2.D0, 310.D0,  18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35808      &  2.D0, 310.D0,  5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35809      &  3.D0, 310.D0,  32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35810      &  3.D0, 310.D0,  7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0  /
35811
35812       DATA TPDG96  /
35813      &  50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35814      &         77.15D0,-21.05D0,0.46D0,0.9D0,
35815      &  50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35816      &         77.15D0,21.05D0,0.46D0,0.9D0,
35817      &  10.D0, 13.70,0.079D0,0.25D0,0.D0,
35818      &         31.85D0,-4.05D0,0.45D0,0.9D0,
35819      &  10.D0, 13.70,0.079D0,0.25D0,0.D0,
35820      &         31.85D0,4.05D0,0.45D0,0.9D0,
35821      &  10.D0, 12.20,0.079D0,0.25D0,0.D0,
35822      &         17.35D0,-9.05D0,0.50D0,0.9D0,
35823      &  10.D0, 12.20,0.079D0,0.25D0,0.D0,
35824      &         17.35D0,9.05D0,0.50D0,0.9D0  /
35825
35826       DATA BURQ83 /
35827      &  11.13D0, -6.21D0, 0.30D0,
35828      &  11.13D0,  7.23D0, 0.30D0,
35829      &  9.11D0,  -0.73D0, 0.28D0,
35830      &  9.11D0,   0.65D0, 0.28D0,
35831      &  8.55D0,  -5.98D0, 0.28D0,
35832      &  8.55D0,   1.60D0, 0.28D0  /
35833
35834       DATA XMA /
35835      &  2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35836
35837 C  find index
35838       IF(ID2.NE.2212) THEN
35839         GOTO 100
35840       ELSE IF(ID1.EQ.2212) THEN
35841         K = 1
35842       ELSE IF(ID1.EQ.-2212) THEN
35843         K = 2
35844       ELSE IF(ID1.EQ.211) THEN
35845         K = 3
35846       ELSE IF(ID1.EQ.-211) THEN
35847         K = 4
35848       ELSE IF(ID1.EQ.321) THEN
35849         K = 5
35850       ELSE IF(ID1.EQ.-321) THEN
35851         K = 6
35852       ELSE
35853         GOTO 100
35854       ENDIF
35855
35856 C  calculate lab momentum
35857       IF(IMODE.EQ.1) THEN
35858         SS = ECM**2
35859         E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35860         PL = SQRT(E1*E1-XMA(K)**2)
35861       ELSE IF(IMODE.EQ.2) THEN
35862         PL = PLAB
35863         SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35864         ECM = SQRT(SS)
35865       ELSE
35866         WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35867         RETURN
35868       ENDIF
35869       PLL = LOG(PL)
35870
35871 C  check against lower limit
35872       IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35873
35874       XP  = TPDG96(2,K)*SS**TPDG96(3,K)
35875       YP  = TPDG96(6,K)/SS**TPDG96(8,K)
35876       YM  = TPDG96(7,K)/SS**TPDG96(8,K)
35877
35878       PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35879       PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35880       RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35881       SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35882
35883 C  select energy range and interpolation method
35884       IF(PL.LT.TPDG96(1,K)) THEN
35885         SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35886      &          + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35887         SIGEL  = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35888      &          + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35889       ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35890         SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35891      &          + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35892         SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35893      &          + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35894         SIGTO2 = YP+YM+XP
35895         SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35896         X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35897         X1 = 1.D0 - X2
35898         SIGTOT = SIGTO2*X2 + SIGTO1*X1
35899         SIGEL  = SIGEL2*X2 + SIGEL1*X1
35900       ELSE
35901         SIGTOT = YP+YM+XP
35902         SIGEL  = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35903       ENDIF
35904
35905 C  no parametrization of diffraction implemented
35906       SIGDIF(1) = -1.D0
35907       SIGDIF(2) = -1.D0
35908       SIGDIF(3) = -1.D0
35909
35910       RETURN
35911
35912  100  CONTINUE
35913         WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35914      &    'invalid particle combination: ',ID1,ID2
35915         RETURN
35916
35917  200  CONTINUE
35918         WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35919      &    'energy too small (Ecm,Plab): ',ECM,PLAB
35920
35921       END
35922
35923 *$ CREATE PHO_CSDIFF.FOR
35924 *COPY PHO_CSDIFF
35925 CDECK  ID>, PHO_CSDIFF
35926       SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35927      &  sig_sd1,sig_sd2,sig_dd)
35928 C***********************************************************************
35929 C
35930 C     cross section for diffraction dissociation according to
35931 C     Goulianos' parametrization (Ref: PL B358 (1995) 379)
35932 C
35933 C     in addition rescaling for different particles is applied using
35934 C     internal rescaling tables (not implemented yet)
35935 C
35936 C     input:     Id1/2       PDG ID's of incoming particles
35937 C                SS          squared c.m. energy (GeV**2)
35938 C                Xi_min      min. diff mass (squared) = Xi_min*SS
35939 C                Xi_max      max. diff mass (squared) = Xi_max*SS
35940 C
35941 C     output:    sig_sd1     cross section for diss. of particle 1 (mb)
35942 C                sig_sd2     cross section for diss. of particle 2 (mb)
35943 C                sig_dd      cross section for diss. of both particles
35944 C
35945 C***********************************************************************
35946
35947       IMPLICIT NONE
35948
35949       SAVE
35950
35951       INTEGER Id1,Id2
35952       DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35953
35954 C  input/output channels
35955       INTEGER LI,LO
35956       COMMON /POINOU/ LI,LO
35957 C  some constants
35958       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35959       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35960      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35961
35962       DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35963       DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35964      &  fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35965      &  xms_1,xms_2,CSdiff
35966
35967       INTEGER Ngau1,Ngau2,i1,i2
35968
35969 C  model parameters
35970
35971       DATA delta    / 0.104d0 /
35972       DATA alphap   / 0.25d0 /
35973       DATA beta0    / 6.56d0 /
35974       DATA gpom0    / 1.21d0 /
35975       DATA xm_p     / 0.938d0 /
35976       DATA x_rad2   / 0.71d0 /
35977
35978 C  integration precision
35979
35980       DATA Ngau1    / 96 /
35981       DATA Ngau2    / 96 /
35982
35983       sig_sd1 = 0.d0
35984       sig_sd2 = 0.d0
35985       sig_dd  = 0.d0
35986
35987       IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35988
35989         xm4_p2 = 4.D0*xm_p**2
35990         fac = beta0**2/(16.D0*PI)
35991
35992         t1 = -5.D0
35993         t2 = 0.D0
35994         tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35995         tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35996
35997 C  flux renormalization and cross section
35998
35999         Xnorm  = 0.d0
36000
36001         xil = log(1.5d0/SS)
36002         xiu = log(0.1d0)
36003
36004         IF(xiu.LE.xil) goto 1000
36005
36006         CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
36007         CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
36008
36009         do i1=1,Ngau1
36010
36011           xi = exp(xpos1(i1))
36012           w_xi = Xwgh1(i1)
36013
36014           do i2=1,Ngau2
36015
36016             tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
36017
36018             alpha_t =  1.D0+delta+alphap*tt
36019             f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
36020
36021             Xnorm = Xnorm
36022      &        + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
36023
36024           enddo
36025         enddo
36026
36027         Xnorm = Xnorm*fac
36028
36029  1000   continue
36030
36031         XIL = LOG(Xi_min)
36032         XIU = LOG(Xi_max)
36033
36034         T1 = -5.D0
36035         T2 = 0.D0
36036
36037         TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
36038         TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
36039
36040 C  single diffraction diss. cross section
36041
36042         CSdiff = 0.d0
36043
36044         IF(XIU.LE.XIL) goto 2000
36045
36046         CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
36047         CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
36048
36049         do i1=1,Ngau1
36050
36051           xi = exp(xpos1(i1))
36052           w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
36053
36054           do i2=1,Ngau2
36055
36056             tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
36057
36058             alpha_t =  1.D0+delta+alphap*tt
36059             f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
36060
36061             CSdiff = CSdiff
36062      &        + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
36063
36064           enddo
36065         enddo
36066
36067         CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
36068
36069 *       WRITE(LO,'(1x,1p,4e14.3)')
36070 *    &    sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
36071
36072         sig_sd1 = CSdiff
36073         sig_sd2 = CSdiff
36074
36075  2000   continue
36076
36077 C  double diffraction dissociation cross section
36078
36079         CSdiff = 0.d0
36080
36081         xil = log(1.5d0/SS)
36082         xiu = log(Xi_max/1.5d0)
36083
36084         IF(xiu.LE.xil) goto 3000
36085
36086         fac = (beta0*gpom0*SS**delta
36087      &         /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
36088      &       /(2.d0*alphap)
36089
36090         CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
36091
36092         do i1=1,Ngau1
36093
36094           xi = exp(xpos1(i1))
36095           xms_1 = xi*SS
36096
36097           xiu = log(Xi_max/(xi*SS))
36098
36099           if(xil.lt.xiu) then
36100
36101             CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
36102
36103             do i2=1,Ngau2
36104
36105               xms_2 = exp(xpos2(i2))*SS
36106               CSdiff = CSdiff
36107      &          + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
36108      &            *xwgh1(i1)*xwgh2(i2)
36109
36110             enddo
36111
36112           endif
36113
36114         enddo
36115
36116         sig_dd = CSdiff*fac*GEV2MB
36117
36118  3000   continue
36119
36120       ELSE
36121
36122         WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
36123      &    'invalid particle combination (Id1/2)',Id1,Id2
36124
36125       ENDIF
36126
36127       END
36128
36129 *$ CREATE PHO_ALLM97.FOR
36130 *COPY PHO_ALLM97
36131 CDECK  ID>, PHO_ALLM97
36132       DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
36133 C**********************************************************************
36134 C
36135 C     ALLM97 parametrization for gamma*-p cross section
36136 C     (for F2 see comments, code adapted from V. Shekelyan, H1)
36137 C
36138 C**********************************************************************
36139
36140       IMPLICIT NONE
36141
36142       SAVE
36143
36144 C  input/output channels
36145       INTEGER LI,LO
36146       COMMON /POINOU/ LI,LO
36147
36148       DOUBLE PRECISION Q2,W
36149       DOUBLE PRECISION M02,M12,LAM2,M22
36150       DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
36151       DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
36152       DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
36153      &                 AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
36154       DATA ALFA,XMP2 /112.2D0 , .8802D0 /
36155
36156       W2=W*W
36157       PHO_ALLM97 = 0.D0
36158
36159 C  pomeron
36160       S11   =   0.28067D0
36161       S12   =   0.22291D0
36162       S13   =   2.1979D0
36163       A11   =  -0.0808D0
36164       A12   =  -0.44812D0
36165       A13   =   1.1709D0
36166       B11   =   0.60243D0
36167       B12   =   1.3754D0
36168       B13   =   1.8439D0
36169       M12   =  49.457D0
36170
36171 C  reggeon
36172       S21   =   0.80107D0
36173       S22   =   0.97307D0
36174       S23   =   3.4942D0
36175       A21   =   0.58400D0
36176       A22   =   0.37888D0
36177       A23   =   2.6063D0
36178       B21   =   0.10711D0
36179       B22   =   1.9386D0
36180       B23   =   0.49338D0
36181       M22   =   0.15052D0
36182 C
36183       M02   =   0.31985D0
36184       LAM2  =   0.065270D0
36185       Q02   =   0.46017D0 +LAM2
36186
36187 C
36188       S=0.
36189       T=LOG((Q2+Q02)/LAM2)
36190       T0=LOG(Q02/LAM2)
36191       IF(Q2.GT.0.D0) S=LOG(T/T0)
36192       Z=1.D0
36193
36194       IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
36195
36196       IF(S.LT.0.01D0) THEN
36197
36198 C   pomeron part
36199
36200         XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
36201
36202         AP=A11
36203         BP=B11**2
36204
36205         SP=S11
36206         F2P=SP*XP**AP*Z**BP
36207
36208 C   reggeon part
36209
36210         XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
36211
36212         AR=A21
36213         BR=B21**2
36214
36215         SR=S21
36216         F2R=SR*XR**AR*Z**BR
36217
36218       ELSE
36219
36220 C   pomeron part
36221
36222         XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
36223
36224         AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
36225
36226         BP=B11**2+B12**2*S**B13
36227
36228         SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
36229
36230         F2P=SP*XP**AP*Z**BP
36231
36232 C   reggeon part
36233
36234         XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
36235
36236         AR=A21+A22*S**A23
36237         BR=B21**2+B22**2*S**B23
36238
36239         SR=S21+S22*S**S23
36240         F2R=SR*XR**AR*Z**BR
36241
36242       ENDIF
36243
36244 *     F2 = (F2P+F2R)*Q2/(Q2+M02)
36245
36246       CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
36247       PHO_ALLM97 = CIN*(F2P+F2R)
36248
36249       END
36250
36251 *$ CREATE PHO_DOR98LO.FOR
36252 *COPY PHO_DOR98LO
36253 CDECK  ID>, PHO_DOR98LO
36254       SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
36255 C***********************************************************************
36256 C
36257 C   GRV98 parton densities, leading order set
36258 C
36259 C                  For a detailed explanation see
36260 C                   M. Glueck, E. Reya, A. Vogt :
36261 C        hep-ph/9806404  =  DO-TH 98/07  =  WUE-ITP-98-019
36262 C                  (To appear in Eur. Phys. J. C)
36263 C
36264 C   interpolation routine based on the original GRV98PA routine,
36265 C   adapted to define interpolation table as DATA statements
36266 C
36267 C                                                   (R.Engel, 09/98)
36268 C
36269 C
36270 C   INPUT:   X  =  Bjorken-x        (between  1.E-9 and 1.)
36271 C            Q2 =  scale in GeV**2  (between  0.8 and 1.E6)
36272 C
36273 C   OUTPUT:  UV = u - u(bar),  DV = d - d(bar),  US = u(bar),
36274 C            DS = d(bar),  SS = s = s(bar),  GL = gluon.
36275 C            Always x times the distribution is returned.
36276 C
36277 C******************************************************i****************
36278       IMPLICIT DOUBLE PRECISION (A-H, O-Z)
36279       SAVE
36280
36281 C  input/output channels
36282       INTEGER LI,LO
36283       COMMON /POINOU/ LI,LO
36284
36285       PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
36286       DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
36287      1          XSF(NX,NQ), XGF(NX,NQ),
36288      2          XT(NARG), NA(NARG), ARRF(NX+NQ)
36289
36290       DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
36291      &  XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
36292
36293       EQUIVALENCE (XUVF(1,1),XUVF_L(1))
36294       EQUIVALENCE (XDVF(1,1),XDVF_L(1))
36295       EQUIVALENCE (XDEF(1,1),XDEF_L(1))
36296       EQUIVALENCE (XUDF(1,1),XUDF_L(1))
36297       EQUIVALENCE (XSF(1,1),XSF_L(1))
36298       EQUIVALENCE (XGF(1,1),XGF_L(1))
36299
36300       DATA (ARRF(K),K=    1,   95) /
36301      &  -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
36302      &  -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
36303      &  -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
36304      &  -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
36305      &  -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
36306      &  -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
36307      &  -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
36308      &  -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
36309      &  -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
36310      &  -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
36311      &  -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
36312      &  -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
36313      &  -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
36314      &  -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
36315      &   2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
36316      &   2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
36317      &   4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
36318      &   7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
36319      &   1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
36320       DATA (XUVF_L(K),K=    1,  114) /
36321      &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
36322      &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
36323      &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
36324      &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
36325      &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
36326      &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
36327      &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
36328      &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
36329      &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
36330      &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
36331      &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
36332      &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
36333      &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
36334      &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
36335      &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
36336      &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
36337      &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
36338      &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
36339      &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
36340       DATA (XUVF_L(K),K=  115,  228) /
36341      &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
36342      &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
36343      &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
36344      &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
36345      &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
36346      &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
36347      &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
36348      &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
36349      &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
36350      &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
36351      &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
36352      &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
36353      &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
36354      &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
36355      &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
36356      &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
36357      &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
36358      &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
36359      &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
36360       DATA (XUVF_L(K),K=  229,  342) /
36361      &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
36362      &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
36363      &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
36364      &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
36365      &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
36366      &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
36367      &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
36368      &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
36369      &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
36370      &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
36371      &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
36372      &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
36373      &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
36374      &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
36375      &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
36376      &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
36377      &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
36378      &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
36379      &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
36380       DATA (XUVF_L(K),K=  343,  456) /
36381      &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
36382      &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
36383      &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
36384      &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
36385      &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
36386      &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
36387      &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
36388      &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
36389      &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
36390      &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
36391      &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
36392      &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
36393      &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
36394      &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
36395      &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
36396      &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
36397      &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
36398      &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
36399      &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
36400       DATA (XUVF_L(K),K=  457,  570) /
36401      &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
36402      &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
36403      &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
36404      &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
36405      &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
36406      &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
36407      &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
36408      &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
36409      &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
36410      &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
36411      &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
36412      &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
36413      &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
36414      &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
36415      &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
36416      &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
36417      &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
36418      &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
36419      &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
36420       DATA (XUVF_L(K),K=  571,  684) /
36421      &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
36422      &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
36423      &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
36424      &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
36425      &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
36426      &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
36427      &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
36428      &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
36429      &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
36430      &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
36431      &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
36432      &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
36433      &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
36434      &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
36435      &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
36436      &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
36437      &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
36438      &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
36439      &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
36440       DATA (XUVF_L(K),K=  685,  798) /
36441      &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
36442      &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36443      &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36444      &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36445      &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36446      &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36447      &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36448      &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36449      &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36450      &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36451      &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36452      &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36453      &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36454      &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36455      &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36456      &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36457      &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36458      &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36459      &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36460       DATA (XUVF_L(K),K=  799,  912) /
36461      &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36462      &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36463      &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36464      &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36465      &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36466      &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36467      &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36468      &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36469      &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36470      &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36471      &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36472      &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36473      &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36474      &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36475      &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36476      &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36477      &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36478      &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36479      &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36480       DATA (XUVF_L(K),K=  913, 1026) /
36481      &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36482      &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36483      &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36484      &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36485      &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36486      &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36487      &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36488      &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36489      &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36490      &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36491      &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36492      &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36493      &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36494      &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36495      &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36496      &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36497      &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36498      &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36499      &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36500       DATA (XUVF_L(K),K= 1027, 1140) /
36501      &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36502      &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36503      &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36504      &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36505      &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36506      &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36507      &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36508      &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36509      &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36510      &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36511      &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36512      &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36513      &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36514      &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36515      &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36516      &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36517      &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36518      &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36519      &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36520       DATA (XUVF_L(K),K= 1141, 1254) /
36521      &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36522      &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36523      &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36524      &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36525      &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36526      &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36527      &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36528      &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36529      &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36530      &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36531      &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36532      &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36533      &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36534      &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36535      &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36536      &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36537      &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36538      &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36539      &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36540       DATA (XUVF_L(K),K= 1255, 1368) /
36541      &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36542      &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36543      &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36544      &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36545      &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36546      &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36547      &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36548      &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36549      &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36550      &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36551      &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36552      &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36553      &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36554      &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36555      &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36556      &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36557      &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36558      &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36559      &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36560       DATA (XUVF_L(K),K= 1369, 1482) /
36561      &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36562      &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36563      &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36564      &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36565      &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36566      &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36567      &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36568      &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36569      &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36570      &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36571      &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36572      &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36573      &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36574      &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36575      &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36576      &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36577      &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36578      &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36579      &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36580       DATA (XUVF_L(K),K= 1483, 1596) /
36581      &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36582      &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36583      &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36584      &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36585      &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36586      &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36587      &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36588      &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36589      &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36590      &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36591      &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36592      &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36593      &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36594      &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36595      &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36596      &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36597      &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36598      &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36599      &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36600       DATA (XUVF_L(K),K= 1597, 1710) /
36601      &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36602      &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36603      &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36604      &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36605      &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36606      &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36607      &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36608      &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36609      &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36610      &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36611      &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36612      &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36613      &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36614      &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36615      &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36616      &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36617      &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36618      &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36619      &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36620       DATA (XUVF_L(K),K= 1711, 1824) /
36621      &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36622      &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36623      &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36624      &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36625      &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36626      &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36627      &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36628      &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36629      &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36630      &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36631      &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36632      &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36633      &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36634      &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36635      &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36636      &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36637      &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36638      &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36639      &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36640       DATA (XUVF_L(K),K= 1825, 1836) /
36641      &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36642      &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36643       DATA (XDVF_L(K),K=    1,  114) /
36644      &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36645      &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36646      &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36647      &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36648      &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36649      &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36650      &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36651      &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36652      &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36653      &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36654      &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36655      &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36656      &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36657      &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36658      &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36659      &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36660      &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36661      &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36662      &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36663       DATA (XDVF_L(K),K=  115,  228) /
36664      &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36665      &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36666      &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36667      &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36668      &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36669      &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36670      &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36671      &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36672      &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36673      &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36674      &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36675      &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36676      &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36677      &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36678      &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36679      &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36680      &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36681      &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36682      &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36683       DATA (XDVF_L(K),K=  229,  342) /
36684      &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36685      &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36686      &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36687      &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36688      &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36689      &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36690      &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36691      &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36692      &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36693      &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36694      &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36695      &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36696      &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36697      &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36698      &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36699      &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36700      &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36701      &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36702      &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36703       DATA (XDVF_L(K),K=  343,  456) /
36704      &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36705      &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36706      &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36707      &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36708      &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36709      &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36710      &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36711      &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36712      &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36713      &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36714      &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36715      &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36716      &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36717      &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36718      &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36719      &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36720      &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36721      &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36722      &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36723       DATA (XDVF_L(K),K=  457,  570) /
36724      &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36725      &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36726      &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36727      &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36728      &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36729      &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36730      &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36731      &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36732      &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36733      &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36734      &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36735      &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36736      &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36737      &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36738      &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36739      &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36740      &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36741      &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36742      &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36743       DATA (XDVF_L(K),K=  571,  684) /
36744      &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36745      &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36746      &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36747      &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36748      &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36749      &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36750      &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36751      &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36752      &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36753      &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36754      &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36755      &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36756      &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36757      &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36758      &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36759      &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36760      &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36761      &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36762      &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36763       DATA (XDVF_L(K),K=  685,  798) /
36764      &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36765      &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36766      &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36767      &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36768      &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36769      &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36770      &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36771      &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36772      &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36773      &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36774      &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36775      &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36776      &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36777      &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36778      &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36779      &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36780      &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36781      &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36782      &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36783       DATA (XDVF_L(K),K=  799,  912) /
36784      &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36785      &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36786      &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36787      &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36788      &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36789      &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36790      &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36791      &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36792      &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36793      &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36794      &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36795      &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36796      &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36797      &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36798      &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36799      &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36800      &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36801      &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36802      &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36803       DATA (XDVF_L(K),K=  913, 1026) /
36804      &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36805      &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36806      &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36807      &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36808      &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36809      &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36810      &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36811      &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36812      &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36813      &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36814      &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36815      &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36816      &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36817      &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36818      &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36819      &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36820      &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36821      &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36822      &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36823       DATA (XDVF_L(K),K= 1027, 1140) /
36824      &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36825      &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36826      &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36827      &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36828      &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36829      &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36830      &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36831      &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36832      &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36833      &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36834      &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36835      &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36836      &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36837      &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36838      &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36839      &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36840      &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36841      &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36842      &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36843       DATA (XDVF_L(K),K= 1141, 1254) /
36844      &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36845      &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36846      &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36847      &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36848      &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36849      &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36850      &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36851      &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36852      &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36853      &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36854      &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36855      &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36856      &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36857      &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36858      &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36859      &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36860      &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36861      &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36862      &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36863       DATA (XDVF_L(K),K= 1255, 1368) /
36864      &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36865      &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36866      &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36867      &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36868      &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36869      &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36870      &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36871      &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36872      &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36873      &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36874      &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36875      &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36876      &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36877      &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36878      &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36879      &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36880      &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36881      &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36882      &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36883       DATA (XDVF_L(K),K= 1369, 1482) /
36884      &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36885      &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36886      &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36887      &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36888      &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36889      &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36890      &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36891      &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36892      &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36893      &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36894      &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36895      &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36896      &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36897      &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36898      &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36899      &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36900      &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36901      &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36902      &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36903       DATA (XDVF_L(K),K= 1483, 1596) /
36904      &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36905      &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36906      &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36907      &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36908      &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36909      &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36910      &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36911      &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36912      &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36913      &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36914      &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36915      &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36916      &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36917      &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36918      &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36919      &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36920      &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36921      &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36922      &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36923       DATA (XDVF_L(K),K= 1597, 1710) /
36924      &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36925      &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36926      &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36927      &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36928      &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36929      &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36930      &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36931      &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36932      &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36933      &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36934      &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36935      &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36936      &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36937      &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36938      &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36939      &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36940      &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36941      &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36942      &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36943       DATA (XDVF_L(K),K= 1711, 1824) /
36944      &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36945      &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36946      &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36947      &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36948      &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36949      &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36950      &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36951      &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36952      &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36953      &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36954      &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36955      &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36956      &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36957      &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36958      &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36959      &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36960      &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36961      &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36962      &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36963       DATA (XDVF_L(K),K= 1825, 1836) /
36964      &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36965      &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36966       DATA (XDEF_L(K),K=    1,  114) /
36967      &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36968      &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36969      &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36970      &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36971      &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36972      &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36973      &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36974      &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36975      &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36976      &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36977      &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36978      &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36979      &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36980      &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36981      &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36982      &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36983      &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36984      &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36985      &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36986       DATA (XDEF_L(K),K=  115,  228) /
36987      &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36988      &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36989      &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36990      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36991      &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36992      &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36993      &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36994      &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36995      &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36996      &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36997      &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36998      &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36999      &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
37000      &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
37001      &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37002      &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
37003      &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
37004      &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
37005      &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
37006       DATA (XDEF_L(K),K=  229,  342) /
37007      &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
37008      &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
37009      &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
37010      &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
37011      &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
37012      &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
37013      &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
37014      &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
37015      &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
37016      &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
37017      &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
37018      &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
37019      &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
37020      &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
37021      &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
37022      &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
37023      &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
37024      &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
37025      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
37026       DATA (XDEF_L(K),K=  343,  456) /
37027      &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
37028      &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
37029      &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
37030      &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
37031      &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
37032      &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
37033      &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
37034      &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
37035      &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
37036      &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
37037      &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37038      &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
37039      &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
37040      &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
37041      &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
37042      &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
37043      &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
37044      &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
37045      &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
37046       DATA (XDEF_L(K),K=  457,  570) /
37047      &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
37048      &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
37049      &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
37050      &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
37051      &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
37052      &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
37053      &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
37054      &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
37055      &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
37056      &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
37057      &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
37058      &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
37059      &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
37060      &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
37061      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
37062      &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
37063      &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
37064      &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
37065      &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
37066       DATA (XDEF_L(K),K=  571,  684) /
37067      &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
37068      &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
37069      &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
37070      &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
37071      &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
37072      &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
37073      &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37074      &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
37075      &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
37076      &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
37077      &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
37078      &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
37079      &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
37080      &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
37081      &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
37082      &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
37083      &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
37084      &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
37085      &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
37086       DATA (XDEF_L(K),K=  685,  798) /
37087      &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
37088      &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
37089      &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
37090      &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
37091      &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
37092      &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
37093      &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
37094      &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
37095      &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
37096      &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
37097      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
37098      &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
37099      &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
37100      &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
37101      &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
37102      &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
37103      &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
37104      &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
37105      &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
37106       DATA (XDEF_L(K),K=  799,  912) /
37107      &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
37108      &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
37109      &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37110      &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
37111      &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
37112      &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
37113      &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
37114      &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
37115      &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
37116      &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
37117      &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
37118      &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
37119      &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
37120      &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37121      &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
37122      &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
37123      &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
37124      &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
37125      &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
37126       DATA (XDEF_L(K),K=  913, 1026) /
37127      &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
37128      &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
37129      &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
37130      &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
37131      &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
37132      &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
37133      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
37134      &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
37135      &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
37136      &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
37137      &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
37138      &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
37139      &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
37140      &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
37141      &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
37142      &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
37143      &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
37144      &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37145      &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
37146       DATA (XDEF_L(K),K= 1027, 1140) /
37147      &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
37148      &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
37149      &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
37150      &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
37151      &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
37152      &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
37153      &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
37154      &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
37155      &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
37156      &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37157      &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
37158      &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
37159      &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
37160      &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
37161      &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
37162      &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
37163      &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
37164      &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
37165      &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
37166       DATA (XDEF_L(K),K= 1141, 1254) /
37167      &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
37168      &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
37169      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
37170      &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
37171      &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
37172      &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
37173      &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
37174      &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
37175      &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
37176      &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
37177      &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
37178      &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
37179      &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
37180      &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37181      &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
37182      &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
37183      &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
37184      &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
37185      &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
37186       DATA (XDEF_L(K),K= 1255, 1368) /
37187      &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
37188      &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
37189      &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
37190      &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
37191      &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
37192      &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37193      &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
37194      &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
37195      &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
37196      &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
37197      &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
37198      &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
37199      &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
37200      &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
37201      &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
37202      &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
37203      &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
37204      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
37205      &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
37206       DATA (XDEF_L(K),K= 1369, 1482) /
37207      &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
37208      &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
37209      &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
37210      &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
37211      &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
37212      &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
37213      &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
37214      &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
37215      &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
37216      &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37217      &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
37218      &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
37219      &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
37220      &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
37221      &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
37222      &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
37223      &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
37224      &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
37225      &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
37226       DATA (XDEF_L(K),K= 1483, 1596) /
37227      &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
37228      &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37229      &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
37230      &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
37231      &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
37232      &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
37233      &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
37234      &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
37235      &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
37236      &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
37237      &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
37238      &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
37239      &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
37240      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
37241      &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
37242      &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
37243      &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
37244      &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
37245      &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
37246       DATA (XDEF_L(K),K= 1597, 1710) /
37247      &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
37248      &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
37249      &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
37250      &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
37251      &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
37252      &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37253      &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
37254      &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
37255      &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
37256      &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
37257      &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
37258      &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
37259      &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
37260      &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
37261      &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
37262      &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
37263      &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37264      &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
37265      &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
37266       DATA (XDEF_L(K),K= 1711, 1824) /
37267      &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
37268      &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
37269      &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
37270      &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
37271      &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
37272      &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
37273      &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
37274      &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
37275      &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
37276      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
37277      &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
37278      &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
37279      &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
37280      &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
37281      &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
37282      &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
37283      &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
37284      &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
37285      &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
37286       DATA (XDEF_L(K),K= 1825, 1836) /
37287      &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
37288      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
37289       DATA (XUDF_L(K),K=    1,  114) /
37290      &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
37291      &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
37292      &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
37293      &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
37294      &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
37295      &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
37296      &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
37297      &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
37298      &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
37299      &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
37300      &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
37301      &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
37302      &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
37303      &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
37304      &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
37305      &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
37306      &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
37307      &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
37308      &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
37309       DATA (XUDF_L(K),K=  115,  228) /
37310      &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
37311      &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
37312      &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
37313      &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
37314      &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
37315      &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
37316      &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
37317      &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
37318      &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
37319      &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
37320      &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
37321      &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
37322      &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
37323      &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
37324      &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
37325      &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
37326      &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
37327      &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
37328      &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
37329       DATA (XUDF_L(K),K=  229,  342) /
37330      &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
37331      &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
37332      &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
37333      &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
37334      &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
37335      &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
37336      &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
37337      &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
37338      &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
37339      &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
37340      &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
37341      &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
37342      &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
37343      &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
37344      &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
37345      &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
37346      &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
37347      &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
37348      &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
37349       DATA (XUDF_L(K),K=  343,  456) /
37350      &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
37351      &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
37352      &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
37353      &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
37354      &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
37355      &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
37356      &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
37357      &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
37358      &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
37359      &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
37360      &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
37361      &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
37362      &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
37363      &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
37364      &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
37365      &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
37366      &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
37367      &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
37368      &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
37369       DATA (XUDF_L(K),K=  457,  570) /
37370      &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
37371      &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
37372      &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
37373      &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
37374      &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
37375      &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
37376      &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
37377      &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
37378      &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
37379      &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
37380      &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
37381      &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
37382      &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
37383      &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
37384      &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
37385      &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
37386      &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
37387      &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
37388      &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
37389       DATA (XUDF_L(K),K=  571,  684) /
37390      &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
37391      &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
37392      &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
37393      &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
37394      &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
37395      &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
37396      &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
37397      &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
37398      &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
37399      &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
37400      &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
37401      &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
37402      &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
37403      &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
37404      &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
37405      &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
37406      &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
37407      &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
37408      &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
37409       DATA (XUDF_L(K),K=  685,  798) /
37410      &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
37411      &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
37412      &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
37413      &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
37414      &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
37415      &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
37416      &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
37417      &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
37418      &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
37419      &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
37420      &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
37421      &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
37422      &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
37423      &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
37424      &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
37425      &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
37426      &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
37427      &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
37428      &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
37429       DATA (XUDF_L(K),K=  799,  912) /
37430      &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
37431      &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
37432      &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
37433      &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
37434      &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
37435      &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
37436      &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
37437      &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
37438      &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
37439      &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
37440      &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
37441      &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
37442      &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37443      &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37444      &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37445      &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37446      &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37447      &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37448      &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37449       DATA (XUDF_L(K),K=  913, 1026) /
37450      &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37451      &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37452      &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37453      &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37454      &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37455      &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37456      &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37457      &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37458      &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37459      &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37460      &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37461      &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37462      &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37463      &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37464      &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37465      &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37466      &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37467      &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37468      &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37469       DATA (XUDF_L(K),K= 1027, 1140) /
37470      &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37471      &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37472      &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37473      &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37474      &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37475      &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37476      &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37477      &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37478      &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37479      &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37480      &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37481      &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37482      &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37483      &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37484      &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37485      &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37486      &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37487      &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37488      &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37489       DATA (XUDF_L(K),K= 1141, 1254) /
37490      &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37491      &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37492      &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37493      &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37494      &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37495      &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37496      &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37497      &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37498      &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37499      &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37500      &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37501      &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37502      &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37503      &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37504      &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37505      &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37506      &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37507      &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37508      &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37509       DATA (XUDF_L(K),K= 1255, 1368) /
37510      &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37511      &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37512      &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37513      &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37514      &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37515      &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37516      &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37517      &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37518      &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37519      &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37520      &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37521      &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37522      &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37523      &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37524      &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37525      &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37526      &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37527      &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37528      &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37529       DATA (XUDF_L(K),K= 1369, 1482) /
37530      &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37531      &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37532      &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37533      &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37534      &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37535      &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37536      &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37537      &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37538      &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37539      &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37540      &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37541      &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37542      &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37543      &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37544      &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37545      &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37546      &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37547      &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37548      &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37549       DATA (XUDF_L(K),K= 1483, 1596) /
37550      &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37551      &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37552      &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37553      &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37554      &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37555      &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37556      &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37557      &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37558      &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37559      &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37560      &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37561      &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37562      &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37563      &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37564      &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37565      &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37566      &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37567      &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37568      &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37569       DATA (XUDF_L(K),K= 1597, 1710) /
37570      &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37571      &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37572      &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37573      &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37574      &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37575      &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37576      &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37577      &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37578      &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37579      &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37580      &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37581      &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37582      &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37583      &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37584      &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37585      &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37586      &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37587      &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37588      &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37589       DATA (XUDF_L(K),K= 1711, 1824) /
37590      &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37591      &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37592      &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37593      &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37594      &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37595      &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37596      &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37597      &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37598      &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37599      &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37600      &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37601      &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37602      &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37603      &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37604      &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37605      &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37606      &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37607      &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37608      &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37609       DATA (XUDF_L(K),K= 1825, 1836) /
37610      &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37611      &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37612       DATA (XSF_L(K),K=    1,  114) /
37613      &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37614      &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37615      &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37616      &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37617      &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37618      &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37619      &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37620      &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37621      &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37622      &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37623      &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37624      &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37625      &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37626      &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37627      &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37628      &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37629      &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37630      &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37631      &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37632       DATA (XSF_L(K),K=  115,  228) /
37633      &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37634      &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37635      &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37636      &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37637      &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37638      &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37639      &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37640      &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37641      &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37642      &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37643      &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37644      &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37645      &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37646      &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37647      &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37648      &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37649      &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37650      &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37651      &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37652       DATA (XSF_L(K),K=  229,  342) /
37653      &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37654      &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37655      &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37656      &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37657      &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37658      &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37659      &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37660      &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37661      &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37662      &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37663      &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37664      &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37665      &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37666      &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37667      &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37668      &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37669      &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37670      &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37671      &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37672       DATA (XSF_L(K),K=  343,  456) /
37673      &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37674      &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37675      &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37676      &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37677      &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37678      &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37679      &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37680      &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37681      &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37682      &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37683      &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37684      &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37685      &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37686      &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37687      &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37688      &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37689      &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37690      &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37691      &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37692       DATA (XSF_L(K),K=  457,  570) /
37693      &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37694      &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37695      &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37696      &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37697      &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37698      &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37699      &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37700      &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37701      &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37702      &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37703      &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37704      &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37705      &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37706      &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37707      &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37708      &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37709      &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37710      &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37711      &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37712       DATA (XSF_L(K),K=  571,  684) /
37713      &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37714      &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37715      &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37716      &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37717      &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37718      &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37719      &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37720      &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37721      &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37722      &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37723      &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37724      &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37725      &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37726      &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37727      &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37728      &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37729      &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37730      &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37731      &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37732       DATA (XSF_L(K),K=  685,  798) /
37733      &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37734      &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37735      &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37736      &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37737      &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37738      &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37739      &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37740      &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37741      &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37742      &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37743      &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37744      &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37745      &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37746      &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37747      &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37748      &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37749      &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37750      &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37751      &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37752       DATA (XSF_L(K),K=  799,  912) /
37753      &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37754      &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37755      &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37756      &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37757      &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37758      &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37759      &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37760      &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37761      &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37762      &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37763      &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37764      &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37765      &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37766      &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37767      &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37768      &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37769      &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37770      &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37771      &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37772       DATA (XSF_L(K),K=  913, 1026) /
37773      &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37774      &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37775      &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37776      &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37777      &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37778      &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37779      &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37780      &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37781      &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37782      &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37783      &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37784      &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37785      &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37786      &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37787      &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37788      &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37789      &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37790      &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37791      &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37792       DATA (XSF_L(K),K= 1027, 1140) /
37793      &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37794      &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37795      &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37796      &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37797      &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37798      &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37799      &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37800      &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37801      &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37802      &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37803      &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37804      &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37805      &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37806      &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37807      &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37808      &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37809      &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37810      &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37811      &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37812       DATA (XSF_L(K),K= 1141, 1254) /
37813      &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37814      &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37815      &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37816      &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37817      &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37818      &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37819      &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37820      &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37821      &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37822      &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37823      &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37824      &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37825      &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37826      &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37827      &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37828      &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37829      &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37830      &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37831      &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37832       DATA (XSF_L(K),K= 1255, 1368) /
37833      &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37834      &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37835      &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37836      &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37837      &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37838      &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37839      &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37840      &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37841      &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37842      &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37843      &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37844      &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37845      &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37846      &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37847      &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37848      &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37849      &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37850      &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37851      &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37852       DATA (XSF_L(K),K= 1369, 1482) /
37853      &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37854      &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37855      &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37856      &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37857      &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37858      &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37859      &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37860      &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37861      &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37862      &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37863      &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37864      &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37865      &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37866      &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37867      &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37868      &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37869      &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37870      &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37871      &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37872       DATA (XSF_L(K),K= 1483, 1596) /
37873      &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37874      &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37875      &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37876      &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37877      &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37878      &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37879      &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37880      &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37881      &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37882      &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37883      &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37884      &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37885      &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37886      &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37887      &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37888      &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37889      &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37890      &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37891      &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37892       DATA (XSF_L(K),K= 1597, 1710) /
37893      &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37894      &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37895      &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37896      &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37897      &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37898      &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37899      &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37900      &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37901      &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37902      &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37903      &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37904      &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37905      &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37906      &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37907      &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37908      &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37909      &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37910      &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37911      &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37912       DATA (XSF_L(K),K= 1711, 1824) /
37913      &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37914      &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37915      &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37916      &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37917      &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37918      &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37919      &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37920      &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37921      &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37922      &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37923      &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37924      &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37925      &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37926      &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37927      &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37928      &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37929      &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37930      &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37931      &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37932       DATA (XSF_L(K),K= 1825, 1836) /
37933      &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37934      &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37935       DATA (XGF_L(K),K=    1,  114) /
37936      &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37937      &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37938      &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37939      &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37940      &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37941      &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37942      &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37943      &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37944      &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37945      &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37946      &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37947      &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37948      &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37949      &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37950      &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37951      &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37952      &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37953      &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37954      &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37955       DATA (XGF_L(K),K=  115,  228) /
37956      &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37957      &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37958      &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37959      &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37960      &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37961      &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37962      &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37963      &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37964      &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37965      &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37966      &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37967      &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37968      &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37969      &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37970      &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37971      &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37972      &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37973      &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37974      &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37975       DATA (XGF_L(K),K=  229,  342) /
37976      &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37977      &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37978      &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37979      &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37980      &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37981      &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37982      &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37983      &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37984      &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37985      &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37986      &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37987      &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37988      &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37989      &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37990      &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37991      &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37992      &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37993      &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37994      &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37995       DATA (XGF_L(K),K=  343,  456) /
37996      &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37997      &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37998      &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37999      &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
38000      &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
38001      &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
38002      &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
38003      &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
38004      &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
38005      &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
38006      &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
38007      &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
38008      &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
38009      &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
38010      &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
38011      &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
38012      &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
38013      &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
38014      &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
38015       DATA (XGF_L(K),K=  457,  570) /
38016      &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
38017      &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
38018      &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
38019      &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
38020      &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
38021      &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
38022      &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
38023      &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
38024      &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
38025      &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
38026      &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
38027      &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
38028      &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
38029      &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
38030      &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
38031      &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
38032      &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
38033      &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
38034      &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
38035       DATA (XGF_L(K),K=  571,  684) /
38036      &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
38037      &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
38038      &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
38039      &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
38040      &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
38041      &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
38042      &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
38043      &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
38044      &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
38045      &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
38046      &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
38047      &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
38048      &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
38049      &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
38050      &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
38051      &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
38052      &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
38053      &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
38054      &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
38055       DATA (XGF_L(K),K=  685,  798) /
38056      &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
38057      &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
38058      &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
38059      &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
38060      &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
38061      &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
38062      &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
38063      &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
38064      &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
38065      &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
38066      &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
38067      &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
38068      &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
38069      &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
38070      &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
38071      &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
38072      &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
38073      &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
38074      &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
38075       DATA (XGF_L(K),K=  799,  912) /
38076      &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
38077      &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
38078      &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
38079      &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
38080      &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
38081      &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
38082      &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
38083      &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
38084      &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
38085      &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
38086      &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
38087      &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
38088      &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
38089      &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
38090      &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
38091      &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
38092      &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
38093      &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
38094      &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
38095       DATA (XGF_L(K),K=  913, 1026) /
38096      &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
38097      &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
38098      &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
38099      &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
38100      &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
38101      &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
38102      &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
38103      &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
38104      &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
38105      &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
38106      &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
38107      &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
38108      &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
38109      &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
38110      &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
38111      &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
38112      &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
38113      &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
38114      &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
38115       DATA (XGF_L(K),K= 1027, 1140) /
38116      &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
38117      &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
38118      &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
38119      &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
38120      &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
38121      &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
38122      &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
38123      &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
38124      &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
38125      &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
38126      &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
38127      &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
38128      &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
38129      &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
38130      &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
38131      &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
38132      &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
38133      &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
38134      &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
38135       DATA (XGF_L(K),K= 1141, 1254) /
38136      &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
38137      &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
38138      &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
38139      &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
38140      &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
38141      &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
38142      &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
38143      &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
38144      &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
38145      &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
38146      &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
38147      &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
38148      &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
38149      &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
38150      &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
38151      &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
38152      &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
38153      &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
38154      &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
38155       DATA (XGF_L(K),K= 1255, 1368) /
38156      &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
38157      &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
38158      &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
38159      &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
38160      &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
38161      &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
38162      &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
38163      &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
38164      &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
38165      &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
38166      &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
38167      &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
38168      &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
38169      &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
38170      &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
38171      &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
38172      &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
38173      &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
38174      &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
38175       DATA (XGF_L(K),K= 1369, 1482) /
38176      &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
38177      &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
38178      &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
38179      &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
38180      &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
38181      &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
38182      &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
38183      &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
38184      &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
38185      &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
38186      &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
38187      &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
38188      &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
38189      &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
38190      &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
38191      &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
38192      &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
38193      &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
38194      &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
38195       DATA (XGF_L(K),K= 1483, 1596) /
38196      &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
38197      &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
38198      &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
38199      &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
38200      &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
38201      &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
38202      &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
38203      &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
38204      &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
38205      &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
38206      &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
38207      &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
38208      &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
38209      &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
38210      &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
38211      &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
38212      &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
38213      &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
38214      &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
38215       DATA (XGF_L(K),K= 1597, 1710) /
38216      &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
38217      &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
38218      &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
38219      &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
38220      &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
38221      &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
38222      &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
38223      &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
38224      &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
38225      &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
38226      &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
38227      &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
38228      &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
38229      &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
38230      &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
38231      &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
38232      &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
38233      &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
38234      &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
38235       DATA (XGF_L(K),K= 1711, 1824) /
38236      &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
38237      &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
38238      &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
38239      &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
38240      &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
38241      &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
38242      &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
38243      &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
38244      &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
38245      &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
38246      &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
38247      &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
38248      &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
38249      &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
38250      &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
38251      &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
38252      &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
38253      &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
38254      &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
38255       DATA (XGF_L(K),K= 1825, 1836) /
38256      &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
38257      &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
38258
38259 *
38260       X = Xinp
38261 *...CHECK OF X AND Q2 VALUES :
38262       IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
38263 *        WRITE(LO,91) X
38264   91     FORMAT (2X,'GRV98: x out of range',1p,E12.4)
38265          X = 0.99D-9
38266 *        STOP
38267       ENDIF
38268
38269       Q2 = Q2inp
38270       IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
38271 *        WRITE(LO,92) Q2
38272   92     FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
38273          Q2 = 0.99E6
38274 *        STOP
38275       ENDIF
38276
38277 *
38278 *...INTERPOLATION :
38279       NA(1) = NX
38280       NA(2) = NQ
38281       XT(1) = DLOG(X)
38282       XT(2) = DLOG(Q2)
38283       X1 = 1.- X
38284       XV = X**0.5
38285       XS = X**(-0.2)
38286       UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
38287       DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
38288       DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
38289       UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
38290       US = 0.5 * (UD - DE)
38291       DS = 0.5 * (UD + DE)
38292       SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF)  * X1**7 * XS
38293       GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF)  * X1**5 * XS
38294
38295       END
38296
38297 *$ CREATE PHO_DOR98SC.FOR
38298 *COPY PHO_DOR98SC
38299 CDECK  ID>, PHO_DOR98SC
38300       SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
38301 C***********************************************************************
38302 C
38303 C   GRV98 parton densities, leading order set
38304 C
38305 C                  For a detailed explanation see
38306 C                   M. Glueck, E. Reya, A. Vogt :
38307 C        hep-ph/9806404  =  DO-TH 98/07  =  WUE-ITP-98-019
38308 C                  (To appear in Eur. Phys. J. C)
38309 C
38310 C   interpolation routine based on the original GRV98PA routine,
38311 C   adapted to define interpolation table as DATA statements
38312 C
38313 C                                                   (R.Engel, 09/98)
38314 C
38315 C   CAUTION: this is a version with gluon shadowing corrections
38316 C                                                   (R.Engel, 09/99)
38317 C
38318 C
38319 C   INPUT:   X  =  Bjorken-x        (between  1.E-9 and 1.)
38320 C            Q2 =  scale in GeV**2  (between  0.8 and 1.E6)
38321 C
38322 C   OUTPUT:  UV = u - u(bar),  DV = d - d(bar),  US = u(bar),
38323 C            DS = d(bar),  SS = s = s(bar),  GL = gluon.
38324 C            Always x times the distribution is returned.
38325 C
38326 C******************************************************i****************
38327       IMPLICIT DOUBLE PRECISION (A-H, O-Z)
38328       SAVE
38329
38330 C  input/output channels
38331       INTEGER LI,LO
38332       COMMON /POINOU/ LI,LO
38333
38334       PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
38335       DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
38336      1          XSF(NX,NQ), XGF(NX,NQ),
38337      2          XT(NARG), NA(NARG), ARRF(NX+NQ)
38338
38339       DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
38340      &  XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
38341
38342       EQUIVALENCE (XUVF(1,1),XUVF_L(1))
38343       EQUIVALENCE (XDVF(1,1),XDVF_L(1))
38344       EQUIVALENCE (XDEF(1,1),XDEF_L(1))
38345       EQUIVALENCE (XUDF(1,1),XUDF_L(1))
38346       EQUIVALENCE (XSF(1,1),XSF_L(1))
38347       EQUIVALENCE (XGF(1,1),XGF_L(1))
38348
38349 *#################### data statements for shadowed LO PDF ##############
38350 C  ... deleted ...
38351 *#######################################################################
38352
38353       X = Xinp
38354 *...CHECK OF X AND Q2 VALUES :
38355       IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
38356 *        WRITE(LO,91) X
38357   91     FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
38358          X = 0.99D-9
38359 *        STOP
38360       ENDIF
38361
38362       Q2 = Q2inp
38363       IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
38364 *        WRITE(LO,92) Q2
38365   92     FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
38366          Q2 = 0.99E6
38367 *        STOP
38368       ENDIF
38369
38370 *
38371 *...INTERPOLATION :
38372       NA(1) = NX
38373       NA(2) = NQ
38374       XT(1) = DLOG(X)
38375       XT(2) = DLOG(Q2)
38376       X1 = 1.- X
38377       XV = X**0.5
38378       XS = X**(-0.2)
38379       UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
38380       DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
38381       DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
38382       UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
38383       US = 0.5 * (UD - DE)
38384       DS = 0.5 * (UD + DE)
38385       SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF)  * X1**7 * XS
38386       GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF)  * X1**5 * XS
38387
38388       END
38389
38390 *$ CREATE PHO_DOR94LO.FOR
38391 *COPY PHO_DOR94LO
38392 CDECK  ID>, PHO_DOR94LO
38393 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38394 *                                                                 *
38395 *    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     *
38396 *                                                                 *
38397 *                         1994 UPDATE                             *
38398 *                                                                 *
38399 *                 FOR A DETAILED EXPLANATION SEE                  *
38400 *                   M. GLUECK, E.REYA, A.VOGT :                   *
38401 *                   DO-TH 94/24  =  DESY 94-206                   *
38402 *                    (TO APPEAR IN Z. PHYS. C)                    *
38403 *                                                                 *
38404 *   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
38405 *        Q**2 / GEV**2  BETWEEN   0.4   AND  1.E6                 *
38406 *             X         BETWEEN  1.E-5  AND   1.                  *
38407 *   LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION   *
38408 *   IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT.              *
38409 *                                                                 *
38410 *   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
38411 *                   M(C)  =  1.5,  M(B)  =  4.5                   *
38412 *   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
38413 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38414 *             LAMBDA(5)  =  0.153,                                *
38415 *      NLO :  LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38416 *             LAMBDA(5)  =  0.131.                                *
38417 *   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
38418 *   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
38419 *   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
38420 *   IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991   *
38421 *   GRV PARAMETRIZATION.                                          *
38422 *                                                                 *
38423 *   NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME    *
38424 *   (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI),  *
38425 *   THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO".   *
38426 *                                                                 *
38427 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38428 *
38429 *...INPUT PARAMETERS :
38430 *
38431 *    X   = MOMENTUM FRACTION
38432 *    Q2  = SCALE Q**2 IN GEV**2
38433 *
38434 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
38435 *
38436 *    UV  = U(VAL) = U - U(BAR)
38437 *    DV  = D(VAL) = D - D(BAR)
38438 *    DEL = D(BAR) - U(BAR)
38439 *    UDB = U(BAR) + D(BAR)
38440 *    SB  = S = S(BAR)
38441 *    GL  = GLUON
38442 *
38443 *...LO PARAMETRIZATION :
38444 *
38445       SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38446       IMPLICIT DOUBLE PRECISION (A - Z)
38447       SAVE
38448
38449        MU2  = 0.23
38450        LAM2 = 0.2322 * 0.2322
38451        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38452        DS = SQRT (S)
38453        S2 = S * S
38454        S3 = S2 * S
38455 *...UV :
38456        NU  =  2.284 + 0.802 * S + 0.055 * S2
38457        AKU =  0.590 - 0.024 * S
38458        BKU =  0.131 + 0.063 * S
38459        AU  = -0.449 - 0.138 * S - 0.076 * S2
38460        BU  =  0.213 + 2.669 * S - 0.728 * S2
38461        CU  =  8.854 - 9.135 * S + 1.979 * S2
38462        DU  =  2.997 + 0.753 * S - 0.076 * S2
38463        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38464 *...DV :
38465        ND  =  0.371 + 0.083 * S + 0.039 * S2
38466        AKD =  0.376
38467        BKD =  0.486 + 0.062 * S
38468        AD  = -0.509 + 3.310 * S - 1.248 * S2
38469        BD  =  12.41 - 10.52 * S + 2.267 * S2
38470        CD  =  6.373 - 6.208 * S + 1.418 * S2
38471        DD  =  3.691 + 0.799 * S - 0.071 * S2
38472        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38473 *...DEL :
38474        NE  =  0.082 + 0.014 * S + 0.008 * S2
38475        AKE =  0.409 - 0.005 * S
38476        BKE =  0.799 + 0.071 * S
38477        AE  = -38.07 + 36.13 * S - 0.656 * S2
38478        BE  =  90.31 - 74.15 * S + 7.645 * S2
38479        CE  =  0.0
38480        DE  =  7.486 + 1.217 * S - 0.159 * S2
38481        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38482 *...UDB :
38483        ALX =  1.451
38484        BEX =  0.271
38485        AKX =  0.410 - 0.232 * S
38486        BKX =  0.534 - 0.457 * S
38487        AGX =  0.890 - 0.140 * S
38488        BGX = -0.981
38489        CX  =  0.320 + 0.683 * S
38490        DX  =  4.752 + 1.164 * S + 0.286 * S2
38491        EX  =  4.119 + 1.713 * S
38492        ESX =  0.682 + 2.978 * S
38493        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38494 *...SB :
38495        ALS =  0.914
38496        BES =  0.577
38497        AKS =  1.798 - 0.596 * S
38498        AS  = -5.548 + 3.669 * DS - 0.616 * S
38499        BS  =  18.92 - 16.73 * DS + 5.168 * S
38500        DST =  6.379 - 0.350 * S  + 0.142 * S2
38501        EST =  3.981 + 1.638 * S
38502        ESS =  6.402
38503        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38504 *...GL :
38505        ALG =  0.524
38506        BEG =  1.088
38507        AKG =  1.742 - 0.930 * S
38508        BKG =        - 0.399 * S2
38509        AG  =  7.486 - 2.185 * S
38510        BG  =  16.69 - 22.74 * S  + 5.779 * S2
38511        CG  = -25.59 + 29.71 * S  - 7.296 * S2
38512        DG  =  2.792 + 2.215 * S  + 0.422 * S2 - 0.104 * S3
38513        EG  =  0.807 + 2.005 * S
38514        ESG =  3.841 + 0.316 * S
38515        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38516
38517        END
38518
38519 *
38520 *...NLO PARAMETRIZATION (MS(BAR)) :
38521 *
38522 *$ CREATE PHO_DOR94HO.FOR
38523 *COPY PHO_DOR94HO
38524 CDECK  ID>, PHO_DOR94HO
38525       SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38526       IMPLICIT DOUBLE PRECISION (A - Z)
38527       SAVE
38528
38529        MU2  = 0.34
38530        LAM2 = 0.248 * 0.248
38531        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38532        DS = SQRT (S)
38533        S2 = S * S
38534        S3 = S2 * S
38535 *...UV :
38536        NU  =  1.304 + 0.863 * S
38537        AKU =  0.558 - 0.020 * S
38538        BKU =          0.183 * S
38539        AU  = -0.113 + 0.283 * S - 0.321 * S2
38540        BU  =  6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38541        CU  =  7.771 - 10.09 * S + 2.630 * S2
38542        DU  =  3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38543        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38544 *...DV :
38545        ND  =  0.102 - 0.017 * S + 0.005 * S2
38546        AKD =  0.270 - 0.019 * S
38547        BKD =  0.260
38548        AD  =  2.393 + 6.228 * S - 0.881 * S2
38549        BD  =  46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38550        CD  =  17.83 - 53.47 * S + 21.24 * S2
38551        DD  =  4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38552        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38553 *...DEL :
38554        NE  =  0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38555        AKE =  0.409 - 0.007 * S
38556        BKE =  0.782 + 0.082 * S
38557        AE  = -29.65 + 26.49 * S + 5.429 * S2
38558        BE  =  90.20 - 74.97 * S + 4.526 * S2
38559        CE  =  0.0
38560        DE  =  8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38561        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38562 *...UDB :
38563        ALX =  0.877
38564        BEX =  0.561
38565        AKX =  0.275
38566        BKX =  0.0
38567        AGX =  0.997
38568        BGX =  3.210 - 1.866 * S
38569        CX  =  7.300
38570        DX  =  9.010 + 0.896 * DS + 0.222 * S2
38571        EX  =  3.077 + 1.446 * S
38572        ESX =  3.173 - 2.445 * DS + 2.207 * S
38573        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38574 *...SB :
38575        ALS =  0.756
38576        BES =  0.216
38577        AKS =  1.690 + 0.650 * DS - 0.922 * S
38578        AS  = -4.329 + 1.131 * S
38579        BS  =  9.568 - 1.744 * S
38580        DST =  9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38581        EST =  3.031 + 1.639 * S
38582        ESS =  5.837 + 0.815 * S
38583        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38584 *...GL :
38585        ALG =  1.014
38586        BEG =  1.738
38587        AKG =  1.724 + 0.157 * S
38588        BKG =  0.800 + 1.016 * S
38589        AG  =  7.517 - 2.547 * S
38590        BG  =  34.09 - 52.21 * DS + 17.47 * S
38591        CG  =  4.039 + 1.491 * S
38592        DG  =  3.404 + 0.830 * S
38593        EG  = -1.112 + 3.438 * S  - 0.302 * S2
38594        ESG =  3.256 - 0.436 * S
38595        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38596
38597        END
38598
38599 *$ CREATE PHO_DOR94DI.FOR
38600 *COPY PHO_DOR94DI
38601 CDECK  ID>, PHO_DOR94DI
38602 *
38603 *...NLO PARAMETRIZATION (DIS) :
38604 *
38605       SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38606       IMPLICIT DOUBLE PRECISION (A - Z)
38607       SAVE
38608
38609        MU2  = 0.34
38610        LAM2 = 0.248 * 0.248
38611        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38612        DS = SQRT (S)
38613        S2 = S * S
38614        S3 = S2 * S
38615 *...UV :
38616        NU  =  2.484 + 0.116 * S + 0.093 * S2
38617        AKU =  0.563 - 0.025 * S
38618        BKU =  0.054 + 0.154 * S
38619        AU  = -0.326 - 0.058 * S - 0.135 * S2
38620        BU  = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38621        CU  =  11.52 - 12.99 * S + 3.161 * S2
38622        DU  =  2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38623        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38624 *...DV :
38625        ND  =  0.156 - 0.017 * S
38626        AKD =  0.299 - 0.022 * S
38627        BKD =  0.259 - 0.015 * S
38628        AD  =  3.445 + 1.278 * S + 0.326 * S2
38629        BD  = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38630        CD  =  55.45 - 69.92 * S + 20.78 * S2
38631        DD  =  3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38632        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38633 *...DEL :
38634        NE  =  0.099 + 0.019 * S + 0.002 * S2
38635        AKE =  0.419 - 0.013 * S
38636        BKE =  1.064 - 0.038 * S
38637        AE  = -44.00 + 98.70 * S - 14.79 * S2
38638        BE  =  28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38639        CE  =  84.57 - 108.8 * S + 31.52 * S2
38640        DE  =  7.469 + 2.480 * S - 0.866 * S2
38641        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38642 *...UDB :
38643        ALX =  1.215
38644        BEX =  0.466
38645        AKX =  0.326 + 0.150 * S
38646        BKX =  0.956 + 0.405 * S
38647        AGX =  0.272
38648        BGX =  3.794 - 2.359 * DS
38649        CX  =  2.014
38650        DX  =  7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38651        EX  =  3.049 + 1.597 * S
38652        ESX =  4.396 - 4.594 * DS + 3.268 * S
38653        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38654 *...SB :
38655        ALS =  0.175
38656        BES =  0.344
38657        AKS =  1.415 - 0.641 * DS
38658        AS  =  0.580 - 9.763 * DS + 6.795 * S  - 0.558 * S2
38659        BS  =  5.617 + 5.709 * DS - 3.972 * S
38660        DST =  13.78 - 9.581 * S  + 5.370 * S2 - 0.996 * S3
38661        EST =  4.546 + 0.372 * S2
38662        ESS =  5.053 - 1.070 * S  + 0.805 * S2
38663        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38664 *...GL :
38665        ALG =  1.258
38666        BEG =  1.846
38667        AKG =  2.423
38668        BKG =  2.427 + 1.311 * S  - 0.153 * S2
38669        AG  =  25.09 - 7.935 * S
38670        BG  = -14.84 - 124.3 * DS + 72.18 * S
38671        CG  =  590.3 - 173.8 * S
38672        DG  =  5.196 + 1.857 * S
38673        EG  = -1.648 + 3.988 * S  - 0.432 * S2
38674        ESG =  3.232 - 0.542 * S
38675        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38676
38677        END
38678
38679 *
38680 *...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38681 *
38682 *$ CREATE PHO_DOR94FV.FOR
38683 *COPY PHO_DOR94FV
38684 CDECK  ID>, PHO_DOR94FV
38685       DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38686       IMPLICIT DOUBLE PRECISION (A - Z)
38687       SAVE
38688
38689        DX = SQRT (X)
38690        PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38691
38692       END
38693
38694 *$ CREATE PHO_DOR94FW.FOR
38695 *COPY PHO_DOR94FW
38696 CDECK  ID>, PHO_DOR94FW
38697       DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38698      &                                      A,B,C,D,E,ES)
38699       IMPLICIT DOUBLE PRECISION (A - Z)
38700       SAVE
38701
38702       LX = LOG (1./X)
38703       PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38704      1     * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38705
38706       END
38707
38708 *$ CREATE PHO_DOR94FS.FOR
38709 *COPY PHO_DOR94FS
38710 CDECK  ID>, PHO_DOR94FS
38711       DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38712       IMPLICIT DOUBLE PRECISION (A - Z)
38713       SAVE
38714
38715       DX = SQRT (X)
38716       LX = LOG (1./X)
38717       PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38718      1      * DEXP (-E + SQRT (ES * S**BE * LX))
38719
38720       END
38721
38722 *$ CREATE PHO_DOR92LO.FOR
38723 *COPY PHO_DOR92LO
38724 CDECK  ID>, PHO_DOR92LO
38725 *
38726 *
38727 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38728 *                                                                 *
38729 *    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     *
38730 *                                                                 *
38731 *                 FOR A DETAILED EXPLANATION SEE :                *
38732 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07             *
38733 *                                                                 *
38734 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38735 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38736 *   / HO) AND  1.E8 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38737 *   REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG-   *
38738 *   LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT.  *
38739 *                                                                 *
38740 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38741 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38742 *                                                                 *
38743 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38744 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38745 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38746 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38747 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38748 *                                                                 *
38749 *   HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL.  *
38750 *                                                                 *
38751 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38752 C
38753       SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38754       IMPLICIT DOUBLE PRECISION (A - Z)
38755       SAVE
38756
38757        MU2  = 0.25
38758        LAM2 = 0.232 * 0.232
38759        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38760        S2 = S * S
38761        S3 = S2 * S
38762 C...X * (UV + DV) :
38763        NUD  = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38764        AKUD = 0.326
38765        AGUD = -1.97 +  6.74 * S -  1.96 * S2
38766        BUD  =  24.4 -  20.7 * S +  4.08 * S2
38767        DUD  =  2.86 +  0.70 * S -  0.02 * S2
38768        UDV  = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38769 C...X * DV :
38770        ND  = 0.579 + 0.283 * S + 0.047 * S2
38771        AKD = 0.523 - 0.015 * S
38772        AGD =  2.22 -  0.59 * S -  0.27 * S2
38773        BD  =  5.95 -  6.19 * S +  1.55 * S2
38774        DD  =  3.57 +  0.94 * S -  0.16 * S2
38775        DV  = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38776 C...X * G :
38777        ALG =  0.558
38778        BEG =  1.218
38779        AKG =   1.00 -  0.17 * S
38780        BKG =   0.0
38781        AGG =   0.0  + 4.879 * S - 1.383 * S2
38782        BGG =  25.92 - 28.97 * S + 5.596 * S2
38783        CG  = -25.69 + 23.68 * S - 1.975 * S2
38784        DG  =  2.537 + 1.718 * S + 0.353 * S2
38785        EG  =  0.595 + 2.138 * S
38786        ESG =  4.066
38787        GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38788 C...X * UBAR = X * DBAR :
38789        ALU =  1.396
38790        BEU =  1.331
38791        AKU =  0.412 - 0.171 * S
38792        BKU =  0.566 - 0.496 * S
38793        AGU =  0.363
38794        BGU = -1.196
38795        CU  =  1.029 + 1.785 * S - 0.459 * S2
38796        DU  =  4.696 + 2.109 * S
38797        EU  =  3.838 + 1.944 * S
38798        ESU =  2.845
38799        UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38800 C...X * SBAR = X * S :
38801        SS  =   0.0
38802        ALS =  0.803
38803        BES =  0.563
38804        AKS =  2.082 - 0.577 * S
38805        AGS = -3.055 + 1.024 * S **  0.67
38806        BS  =   27.4 -  20.0 * S ** 0.154
38807        DS  =   6.22
38808        EST =   4.33 + 1.408 * S
38809        ESS =   8.27 - 0.437 * S
38810        SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38811 C...X * CBAR = X * C :
38812        SC  =  0.888
38813        ALC =   1.01
38814        BEC =   0.37
38815        AKC =   0.0
38816        AGC =   0.0
38817        BC  =   4.24 - 0.804 * S
38818        DC  =   3.46 + 1.076 * S
38819        EC  =   4.61 + 1.490 * S
38820        ESC =  2.555 + 1.961 * S
38821        CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38822 C...X * BBAR = X * B :
38823        SBO =  1.351
38824        ALB =   1.00
38825        BEB =   0.51
38826        AKB =   0.0
38827        AGB =   0.0
38828        BBO =  1.848
38829        DB  =  2.929 + 1.396 * S
38830        EB  =   4.71 + 1.514 * S
38831        ESB =   4.02 + 1.239 * S
38832        BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38833
38834       END
38835
38836 *$ CREATE PHO_DOR92HO.FOR
38837 *COPY PHO_DOR92HO
38838 CDECK  ID>, PHO_DOR92HO
38839       SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38840       IMPLICIT DOUBLE PRECISION (A - Z)
38841       SAVE
38842
38843        MU2  = 0.3
38844        LAM2 = 0.248 * 0.248
38845        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38846        DS = SQRT (S)
38847        S2 = S * S
38848        S3 = S2 * S
38849 C...X * (UV + DV) :
38850        NUD  = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38851        AKUD = 0.285
38852        AGUD = -2.28 + 15.73 * S -  4.58 * S2
38853        BUD  =  56.7 -  53.6 * S + 11.21 * S2
38854        DUD  =  3.17 +  1.17 * S -  0.47 * S2 +  0.09 * S3
38855        UDV  = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38856 C...X * DV :
38857        ND  = 0.459 + 0.315 * DS + 0.515 * S
38858        AKD = 0.624              - 0.031 * S
38859        AGD =  8.13 -  6.77 * DS +  0.46 * S
38860        BD  =  6.59 - 12.83 * DS +  5.65 * S
38861        DD  =  3.98              +  1.04 * S  -  0.34 * S2
38862        DV  = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38863 C...X * G :
38864        ALG =  1.128
38865        BEG =  1.575
38866        AKG =  0.323 + 1.653 * S
38867        BKG =  0.811 + 2.044 * S
38868        AGG =   0.0  + 1.963 * S - 0.519 * S2
38869        BGG =  0.078 +  6.24 * S
38870        CG  =  30.77 - 24.19 * S
38871        DG  =  3.188 + 0.720 * S
38872        EG  = -0.881 + 2.687 * S
38873        ESG =  2.466
38874        GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38875 C...X * UBAR = X * DBAR :
38876        ALU =  0.594
38877        BEU =  0.614
38878        AKU =  0.636 - 0.084 * S
38879        BKU =   0.0
38880        AGU =  1.121 - 0.193 * S
38881        BGU =  0.751 - 0.785 * S
38882        CU  =   8.57 - 1.763 * S
38883        DU  =  10.22 + 0.668 * S
38884        EU  =  3.784 + 1.280 * S
38885        ESU =  1.808 + 0.980 * S
38886        UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38887 C...X * SBAR = X * S :
38888        SS  =   0.0
38889        ALS =  0.756
38890        BES =  0.101
38891        AKS =  2.942 - 1.016 * S
38892        AGS =  -4.60 + 1.167 * S
38893        BS  =   9.31 - 1.324 * S
38894        DS  =  11.49 - 1.198 * S + 0.053 * S2
38895        EST =  2.630 + 1.729 * S
38896        ESS =   8.12
38897        SB  = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38898 C...X * CBAR = X * C :
38899        SC  =  0.820
38900        ALC =   0.98
38901        BEC =   0.0
38902        AKC = -0.625 - 0.523 * S
38903        AGC =   0.0
38904        BC  =  1.896 + 1.616 * S
38905        DC  =   4.12 + 0.683 * S
38906        EC  =   4.36 + 1.328 * S
38907        ESC =  0.677 + 0.679 * S
38908        CB  = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38909 C...X * BBAR = X * B :
38910        SBO =  1.297
38911        ALB =   0.99
38912        BEB =   0.0
38913        AKB =   0.0  - 0.193 * S
38914        AGB =   0.0
38915        BBO =   0.0
38916        DB  =  3.447 + 0.927 * S
38917        EB  =   4.68 + 1.259 * S
38918        ESB =  1.892 + 2.199 * S
38919        BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38920
38921       END
38922
38923 *$ CREATE PHO_DOR92FV.FOR
38924 *COPY PHO_DOR92FV
38925 CDECK  ID>, PHO_DOR92FV
38926       DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38927       IMPLICIT DOUBLE PRECISION (A - Z)
38928       SAVE
38929        DX = SQRT (X)
38930        PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38931
38932       END
38933
38934 *$ CREATE PHO_DOR92FW.FOR
38935 *COPY PHO_DOR92FW
38936 CDECK  ID>, PHO_DOR92FW
38937       DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38938      &                                      AL,BE,AK,BK,AG,BG,C,D,E,ES)
38939       IMPLICIT DOUBLE PRECISION (A - Z)
38940       SAVE
38941        LX = LOG (1./X)
38942        PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38943      1      * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38944
38945       END
38946
38947 *$ CREATE PHO_DOR92FS.FOR
38948 *COPY PHO_DOR92FS
38949 CDECK  ID>, PHO_DOR92FS
38950       DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38951       IMPLICIT DOUBLE PRECISION (A - Z)
38952       SAVE
38953
38954        DX = SQRT (X)
38955        LX = LOG (1./X)
38956        IF (S .LE. ST) THEN
38957          PHO_DOR92FS = 0.D0
38958        ELSE
38959          PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38960      1          * EXP (-E + SQRT (ES * S**BE * LX))
38961        END IF
38962
38963       END
38964
38965 *$ CREATE PHO_DORPLO.FOR
38966 *COPY PHO_DORPLO
38967 CDECK  ID>, PHO_DORPLO
38968 *
38969 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38970 *                                                                 *
38971 *         G R V - P I O N - P A R A M E T R I Z A T I O N S       *
38972 *                                                                 *
38973 *                 FOR A DETAILED EXPLANATION SEE :                *
38974 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16             *
38975 *                                                                 *
38976 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38977 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38978 *   / HO) AND  1.E8 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38979 *   REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG-   *
38980 *   LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT.  *
38981 *                                                                 *
38982 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38983 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38984 *                                                                 *
38985 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38986 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38987 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38988 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38989 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38990 *                                                                 *
38991 *   HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL.  *
38992 *                                                                 *
38993 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38994 C
38995       SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38996       IMPLICIT DOUBLE PRECISION (A - Z)
38997       SAVE
38998
38999        MU2  = 0.25
39000        LAM2 = 0.232 * 0.232
39001        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39002        DS = SQRT (S)
39003        S2 = S * S
39004 C...X * VALENCE :
39005        NV  =  0.519 + 0.180 * S - 0.011 * S2
39006        AKV =  0.499 - 0.027 * S
39007        AGV =  0.381 - 0.419 * S
39008        DV  =  0.367 + 0.563 * S
39009        VAP =  PHO_DORFVP (X, NV, AKV, AGV, DV)
39010 C...X * GLUON :
39011        ALG =  0.599
39012        BEG =  1.263
39013        AKG =  0.482 + 0.341 * DS
39014        BKG =   0.0
39015        AGG =  0.678 + 0.877 * S  - 0.175 * S2
39016        BGG =  0.338 - 1.597 * S
39017        CG  =   0.0  - 0.233 * S  + 0.406 * S2
39018        DG  =  0.390 + 1.053 * S
39019        EG  =  0.618 + 2.070 * S
39020        ESG =  3.676
39021        GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
39022 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
39023        SL  =   0.0
39024        ALS =   0.55
39025        BES =   0.56
39026        AKS =  2.538 - 0.763 * S
39027        AGS = -0.748
39028        BS  =  0.313 + 0.935 * S
39029        DS  =  3.359
39030        EST =  4.433 + 1.301 * S
39031        ESS =   9.30 - 0.887 * S
39032        QBP =  PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
39033 C...X * CBAR = X * C :
39034        SC  =  0.888
39035        ALC =   1.02
39036        BEC =   0.39
39037        AKC =   0.0
39038        AGC =   0.0
39039        BC  =  1.008
39040        DC  =  1.208 + 0.771 * S
39041        EC  =   4.40 + 1.493 * S
39042        ESC =  2.032 + 1.901 * S
39043        CBP =  PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
39044 C...X * BBAR = X * B :
39045        SBO =  1.351
39046        ALB =   1.03
39047        BEB =   0.39
39048        AKB =   0.0
39049        AGB =   0.0
39050        BBO =   0.0
39051        DB  =  0.697 + 0.855 * S
39052        EB  =   4.51 + 1.490 * S
39053        ESB =  3.056 + 1.694 * S
39054        BBP =  PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
39055
39056        END
39057
39058 *$ CREATE PHO_DORPHO.FOR
39059 *COPY PHO_DORPHO
39060 CDECK  ID>, PHO_DORPHO
39061       SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
39062       IMPLICIT DOUBLE PRECISION (A - Z)
39063       SAVE
39064
39065        MU2  = 0.3
39066        LAM2 = 0.248 * 0.248
39067        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39068        DS = SQRT (S)
39069        S2 = S * S
39070 C...X * VALENCE :
39071        NV  =  0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
39072        AKV =  0.505 - 0.033 * S
39073        AGV =  0.748 - 0.669 * DS - 0.133 * S
39074        DV  =  0.365 + 0.197 * DS + 0.394 * S
39075        VAP =  PHO_DORFVP (X, NV, AKV, AGV, DV)
39076 C...X * GLUON :
39077        ALG =  1.096
39078        BEG =  1.371
39079        AKG =  0.437 - 0.689 * DS
39080        BKG = -0.631
39081        AGG =  1.324 - 0.441 * DS - 0.130 * S
39082        BGG = -0.955 + 0.259 * S
39083        CG  =  1.075 - 0.302 * S
39084        DG  =  1.158 + 1.229 * S
39085        EG  =   0.0  + 2.510 * S
39086        ESG =  2.604 + 0.165 * S
39087        GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
39088 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
39089        SL  =   0.0
39090        ALS =   0.85
39091        BES =   0.96
39092        AKS = -0.350 + 0.806 * S
39093        AGS = -1.663
39094        BS  =  3.148
39095        DS  =  2.273 + 1.438 * S
39096        EST =  3.214 + 1.545 * S
39097        ESS =  1.341 + 1.938 * S
39098        QBP =  PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
39099 C...X * CBAR = X * C :
39100        SC  =  0.820
39101        ALC =   0.98
39102        BEC =   0.0
39103        AKC =   0.0  - 0.457 * S
39104        AGC =   0.0
39105        BC  =  -1.00 +  1.40 * S
39106        DC  =  1.318 + 0.584 * S
39107        EC  =   4.45 + 1.235 * S
39108        ESC =  1.496 + 1.010 * S
39109        CBP =  PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
39110 C...X * BBAR = X * B :
39111        SBO =  1.297
39112        ALB =   0.99
39113        BEB =   0.0
39114        AKB =   0.0  - 0.172 * S
39115        AGB =   0.0
39116        BBO =   0.0
39117        DB  =  1.447 + 0.485 * S
39118        EB  =   4.79 + 1.164 * S
39119        ESB =  1.724 + 2.121 * S
39120        BBP =  PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
39121
39122       END
39123
39124 *$ CREATE PHO_DORFVP.FOR
39125 *COPY PHO_DORFVP
39126 CDECK  ID>, PHO_DORFVP
39127       DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
39128       IMPLICIT DOUBLE PRECISION (A - Z)
39129       SAVE
39130
39131        DX = SQRT (X)
39132        PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
39133
39134       END
39135
39136 *$ CREATE PHO_DORFGP.FOR
39137 *COPY PHO_DORFGP
39138 CDECK  ID>, PHO_DORFGP
39139       DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
39140      &                                    BG,C,D,E,ES)
39141       IMPLICIT DOUBLE PRECISION (A - Z)
39142       SAVE
39143
39144        DX = SQRT (X)
39145        LX = LOG (1./X)
39146        PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
39147      1       * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39148
39149       END
39150
39151 *$ CREATE PHO_DORFQP.FOR
39152 *COPY PHO_DORFQP
39153 CDECK  ID>, PHO_DORFQP
39154       DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
39155       IMPLICIT DOUBLE PRECISION (A - Z)
39156       SAVE
39157
39158        DX = SQRT (X)
39159        LX = LOG (1./X)
39160        IF (S .LE. ST) THEN
39161           PHO_DORFQP = 0.0
39162        ELSE
39163           PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
39164      1           * EXP (-E + SQRT (ES * S**BE * LX))
39165        END IF
39166
39167       END
39168
39169 *$ CREATE PHO_DORGLO.FOR
39170 *COPY PHO_DORGLO
39171 CDECK  ID>, PHO_DORGLO
39172 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39173 *                                                                 *
39174 *      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      *
39175 *                                                                 *
39176 *                 FOR A DETAILED EXPLANATION SEE :                *
39177 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31             *
39178 *                                                                 *
39179 *    THE OUTPUT IS ALWAYS   1./ ALPHA(EM) * X * PARTON DENSITY    *
39180 *                                                                 *
39181 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
39182 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
39183 *   / HO) AND  1.E6 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
39184 *                                                                 *
39185 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
39186 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
39187 *                                                                 *
39188 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
39189 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
39190 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
39191 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
39192 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
39193 *                                                                 *
39194 *      HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE :     *
39195 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26             *
39196 *                                                                 *
39197 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39198 C
39199       SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
39200       IMPLICIT DOUBLE PRECISION (A - Z)
39201       SAVE
39202
39203        MU2  = 0.25
39204        LAM2 = 0.232 * 0.232
39205        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39206        SS = SQRT (S)
39207        S2 = S * S
39208 C...X * U = X * UBAR :
39209        AL =  1.717
39210        BE =  0.641
39211        AK =  0.500 - 0.176 * S
39212        BK = 15.00  - 5.687 * SS - 0.552 * S2
39213        AG =  0.235 + 0.046 * SS
39214        BG =  0.082 - 0.051 * S  + 0.168 * S2
39215        C  =   0.0  + 0.459 * S
39216        D  =  0.354 - 0.061 * S
39217        E  =  4.899 + 1.678 * S
39218        ES =  2.046 + 1.389 * S
39219        UL =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39220 C...X * D = X * DBAR :
39221        AL =  1.549
39222        BE =  0.782
39223        AK =  0.496 + 0.026 * S
39224        BK =  0.685 - 0.580 * SS + 0.608 * S2
39225        AG =  0.233 + 0.302 * S
39226        BG =   0.0  - 0.818 * S  + 0.198 * S2
39227        C  =  0.114 + 0.154 * S
39228        D  =  0.405 - 0.195 * S  + 0.046 * S2
39229        E  =  4.807 + 1.226 * S
39230        ES =  2.166 + 0.664 * S
39231        DL  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39232 C...X * G :
39233        AL =  0.676
39234        BE =  1.089
39235        AK =  0.462 - 0.524 * SS
39236        BK =  5.451              - 0.804 * S2
39237        AG =  0.535 - 0.504 * SS + 0.288 * S2
39238        BG =  0.364 - 0.520 * S
39239        C  = -0.323              + 0.115 * S2
39240        D  =  0.233 + 0.790 * S  - 0.139 * S2
39241        E  =  0.893 + 1.968 * S
39242        ES =  3.432 + 0.392 * S
39243        GL =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39244 C...X * S = X * SBAR :
39245        SF =   0.0
39246        AL =  1.609
39247        BE =  0.962
39248        AK =  0.470              - 0.099 * S2
39249        BK =  3.246
39250        AG =  0.121 - 0.068 * SS
39251        BG = -0.090 + 0.074 * S
39252        C  =  0.062 + 0.034 * S
39253        D  =   0.0  + 0.226 * S  - 0.060 * S2
39254        E  =  4.288 + 1.707 * S
39255        ES =  2.122 + 0.656 * S
39256        SL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39257 C...X * C = X * CBAR :
39258        SF =  0.888
39259        AL =  0.970
39260        BE =  0.545
39261        AK =  1.254 - 0.251 * S
39262        BK =  3.932              - 0.327 * S2
39263        AG =  0.658 + 0.202 * S
39264        BG = -0.699
39265        C  =  0.965
39266        D  =   0.0  + 0.141 * S  - 0.027 * S2
39267        E  =  4.911 + 0.969 * S
39268        ES =  2.796 + 0.952 * S
39269        CL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39270 C...X * B = X * BBAR :
39271        SF =  1.351
39272        AL =  1.016
39273        BE =  0.338
39274        AK =  1.961 - 0.370 * S
39275        BK =  0.923 + 0.119 * S
39276        AG =  0.815 + 0.207 * S
39277        BG = -2.275
39278        C  =  1.480
39279        D  = -0.223 + 0.173 * S
39280        E  =  5.426 + 0.623 * S
39281        ES =  3.819 + 0.901 * S
39282        BL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39283
39284        END
39285
39286 *$ CREATE PHO_DORGHO.FOR
39287 *COPY PHO_DORGHO
39288 CDECK  ID>, PHO_DORGHO
39289       SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
39290       IMPLICIT DOUBLE PRECISION (A - Z)
39291       SAVE
39292
39293        MU2  = 0.3
39294        LAM2 = 0.248 * 0.248
39295        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39296        SS = SQRT (S)
39297        S2 = S * S
39298 C...X * U = X * UBAR :
39299        AL =  0.583
39300        BE =  0.688
39301        AK =  0.449 - 0.025 * S  - 0.071 * S2
39302        BK =  5.060 - 1.116 * SS
39303        AG =  0.103
39304        BG =  0.319 + 0.422 * S
39305        C  =  1.508 + 4.792 * S  - 1.963 * S2
39306        D  =  1.075 + 0.222 * SS - 0.193 * S2
39307        E  =  4.147 + 1.131 * S
39308        ES =  1.661 + 0.874 * S
39309        UH =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39310 C...X * D = X * DBAR :
39311        AL =  0.591
39312        BE =  0.698
39313        AK =  0.442 - 0.132 * S  - 0.058 * S2
39314        BK =  5.437 - 1.916 * SS
39315        AG =  0.099
39316        BG =  0.311 - 0.059 * S
39317        C  =  0.800 + 0.078 * S  - 0.100 * S2
39318        D  =  0.862 + 0.294 * SS - 0.184 * S2
39319        E  =  4.202 + 1.352 * S
39320        ES =  1.841 + 0.990 * S
39321        DH  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39322 C...X * G :
39323        AL =  1.161
39324        BE =  1.591
39325        AK =  0.530 - 0.742 * SS + 0.025 * S2
39326        BK =  5.662
39327        AG =  0.533 - 0.281 * SS + 0.218 * S2
39328        BG =  0.025 - 0.518 * S  + 0.156 * S2
39329        C  = -0.282              + 0.209 * S2
39330        D  =  0.107 + 1.058 * S  - 0.218 * S2
39331        E  =   0.0  + 2.704 * S
39332        ES =  3.071 - 0.378 * S
39333        GH =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39334 C...X * S = X * SBAR :
39335        SF =   0.0
39336        AL =  0.635
39337        BE =  0.456
39338        AK =  1.770 - 0.735 * SS - 0.079 * S2
39339        BK =  3.832
39340        AG =  0.084 - 0.023 * S
39341        BG =  0.136
39342        C  =  2.119 - 0.942 * S  + 0.063 * S2
39343        D  =  1.271 + 0.076 * S  - 0.190 * S2
39344        E  =  4.604 + 0.737 * S
39345        ES =  1.641 + 0.976 * S
39346        SH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39347 C...X * C = X * CBAR :
39348        SF =  0.820
39349        AL =  0.926
39350        BE =  0.152
39351        AK =  1.142 - 0.175 * S
39352        BK =  3.276
39353        AG =  0.504 + 0.317 * S
39354        BG = -0.433
39355        C  =  3.334
39356        D  =  0.398 + 0.326 * S  - 0.107 * S2
39357        E  =  5.493 + 0.408 * S
39358        ES =  2.426 + 1.277 * S
39359        CH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39360 C...X * B = X * BBAR :
39361        SF =  1.297
39362        AL =  0.969
39363        BE =  0.266
39364        AK =  1.953 - 0.391 * S
39365        BK =  1.657 - 0.161 * S
39366        AG =  1.076 + 0.034 * S
39367        BG = -2.015
39368        C  =  1.662
39369        D  =  0.353 + 0.016 * S
39370        E  =  5.713 + 0.249 * S
39371        ES =  3.456 + 0.673 * S
39372        BH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39373
39374       END
39375
39376 *$ CREATE PHO_DORGH0.FOR
39377 *COPY PHO_DORGH0
39378 CDECK  ID>, PHO_DORGH0
39379       SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
39380       IMPLICIT DOUBLE PRECISION (A - Z)
39381       SAVE
39382
39383        MU2  = 0.3
39384        LAM2 = 0.248 * 0.248
39385        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39386        SS = SQRT (S)
39387        S2 = S * S
39388 C...X * U = X * UBAR :
39389        AL =  1.447
39390        BE =  0.848
39391        AK =  0.527 + 0.200 * S  - 0.107 * S2
39392        BK =  7.106 - 0.310 * SS - 0.786 * S2
39393        AG =  0.197 + 0.533 * S
39394        BG =  0.062 - 0.398 * S  + 0.109 * S2
39395        C  =          0.755 * S  - 0.112 * S2
39396        D  =  0.318 - 0.059 * S
39397        E  =  4.225 + 1.708 * S
39398        ES =  1.752 + 0.866 * S
39399        U0 =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39400 C...X * D = X * DBAR :
39401        AL =  1.424
39402        BE =  0.770
39403        AK =  0.500 + 0.067 * SS - 0.055 * S2
39404        BK =  0.376 - 0.453 * SS + 0.405 * S2
39405        AG =  0.156 + 0.184 * S
39406        BG =   0.0  - 0.528 * S  + 0.146 * S2
39407        C  =  0.121 + 0.092 * S
39408        D  =  0.379 - 0.301 * S  + 0.081 * S2
39409        E  =  4.346 + 1.638 * S
39410        ES =  1.645 + 1.016 * S
39411        D0  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39412 C...X * G :
39413        AL =  0.661
39414        BE =  0.793
39415        AK =  0.537 - 0.600 * SS
39416        BK =  6.389              - 0.953 * S2
39417        AG =  0.558 - 0.383 * SS + 0.261 * S2
39418        BG =   0.0  - 0.305 * S
39419        C  = -0.222              + 0.078 * S2
39420        D  =  0.153 + 0.978 * S  - 0.209 * S2
39421        E  =  1.429 + 1.772 * S
39422        ES =  3.331 + 0.806 * S
39423        G0 =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39424 C...X * S = X * SBAR :
39425        SF =   0.0
39426        AL =  1.578
39427        BE =  0.863
39428        AK =  0.622 + 0.332 * S  - 0.300 * S2
39429        BK =  2.469
39430        AG =  0.211 - 0.064 * SS - 0.018 * S2
39431        BG = -0.215 + 0.122 * S
39432        C  =  0.153
39433        D  =   0.0  + 0.253 * S  - 0.081 * S2
39434        E  =  3.990 + 2.014 * S
39435        ES =  1.720 + 0.986 * S
39436        S0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39437 C...X * C = X * CBAR :
39438        SF =  0.820
39439        AL =  0.929
39440        BE =  0.381
39441        AK =  1.228 - 0.231 * S
39442        BK =  3.806             - 0.337 * S2
39443        AG =  0.932 + 0.150 * S
39444        BG = -0.906
39445        C  =  1.133
39446        D  =   0.0  + 0.138 * S  - 0.028 * S2
39447        E  =  5.588 + 0.628 * S
39448        ES =  2.665 + 1.054 * S
39449        C0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39450 C...X * B = X * BBAR :
39451        SF =  1.297
39452        AL =  0.970
39453        BE =  0.207
39454        AK =  1.719 - 0.292 * S
39455        BK =  0.928 + 0.096 * S
39456        AG =  0.845 + 0.178 * S
39457        BG = -2.310
39458        C  =  1.558
39459        D  = -0.191 + 0.151 * S
39460        E  =  6.089 + 0.282 * S
39461        ES =  3.379 + 1.062 * S
39462        B0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39463
39464       END
39465
39466 *$ CREATE PHO_DORGF.FOR
39467 *COPY PHO_DORGF
39468 CDECK  ID>, PHO_DORGF
39469       DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39470      &                                   AG,BG,C,D,E,ES)
39471       IMPLICIT DOUBLE PRECISION (A - Z)
39472       SAVE
39473
39474        SX = SQRT (X)
39475        LX = LOG (1./X)
39476        PHO_DORGF  = (X**AK * (AG + BG * SX + C * X**BK)  +  S**AL
39477      1       * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39478
39479       END
39480
39481 *$ CREATE PHO_DORGFS.FOR
39482 *COPY PHO_DORGFS
39483 CDECK  ID>, PHO_DORGFS
39484       DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39485      &                                     C,D,E,ES)
39486       IMPLICIT DOUBLE PRECISION (A - Z)
39487       SAVE
39488
39489        IF (S .LE. SF) THEN
39490           PHO_DORGFS = 0.0
39491        ELSE
39492           SX = SQRT (X)
39493           LX = LOG (1./X)
39494           DS = S - SF
39495           PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39496      1         * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39497        END IF
39498
39499       END
39500
39501 *$ CREATE PHO_DORGLV.FOR
39502 *COPY PHO_DORGLV
39503 CDECK  ID>, PHO_DORGLV
39504 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39505 *                                                                 *
39506 *           G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS          *
39507 *                                                                 *
39508 *                 FOR A DETAILED EXPLANATION SEE                  *
39509 *                M. GLUECK, E.REYA, M. STRATMANN :                *
39510 *                    PHYS. REV. D51 (1995) 3220                   *
39511 *                                                                 *
39512 *   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
39513 *        Q**2 / GEV**2  BETWEEN   0.6   AND  5.E4                 *
39514 *                       AND (!)  Q**2 > 5 P**2                    *
39515 *        P**2 / GEV**2  BETWEEN   0.0   AND  10.                  *
39516 *                       P**2 = 0  <=> REAL PHOTON                 *
39517 *             X         BETWEEN  1.E-4  AND   1.                  *
39518 *                                                                 *
39519 *   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
39520 *                   M(C)  =  1.5,  M(B)  =  4.5                   *
39521 *   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
39522 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
39523 *             LAMBDA(5)  =  0.153,                                *
39524 *   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
39525 *   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
39526 *   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
39527 *                                                                 *
39528 *   PLEASE REPORT ANY STRANGE BEHAVIOUR TO :                      *
39529 *                  Marco.Stratmann@durham.ac.uk                   *
39530 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39531 *
39532 *...INPUT PARAMETERS :
39533 *
39534 *    X   = MOMENTUM FRACTION
39535 *    Q2  = SCALE Q**2 IN GEV**2
39536 *    P2  = VIRTUALITY OF THE PHOTON IN GEV**2
39537 *
39538 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39539 *
39540 ********************************************************
39541 *     subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39542       subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39543       implicit double precision (a-z)
39544       save
39545
39546 C  input/output channels
39547       INTEGER LI,LO
39548       COMMON /POINOU/ LI,LO
39549
39550       integer check
39551 c
39552 c     check limits :
39553 c
39554       check=0
39555       if(x.lt.0.0001d0) check=1
39556       if((q2.lt.0.6d0).or.(q2.gt.50000.d0))  check=1
39557       if(q2.lt.5.d0*p2) check=1
39558 c
39559 c     calculate distributions
39560 c
39561       if(check.eq.0) then
39562          call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39563       else
39564          WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39565          WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39566       endif
39567
39568       end
39569
39570 *$ CREATE PHO_grscalc.FOR
39571 *COPY PHO_grscalc
39572 CDECK  ID>, PHO_grscalc
39573       subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39574       implicit double precision (a-z)
39575       save
39576
39577       dimension u1(40),ds1(40),g1(40)
39578       dimension ud2(20),s2(20),g2(20)
39579       dimension up0(20),dsp0(20),gp0(20)
39580 **sr
39581 C     save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
39582 **
39583 c
39584       data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39585      &   0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39586      &   0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39587      &   0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39588      &   0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39589      &   -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39590      &   0.622d0,0.227d0,-0.184d0/
39591       data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39592      &   0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39593      &   0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39594      &   0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39595      &   0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39596      &   0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39597      &   0.245d0,-0.171d0/
39598       data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39599      &   -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39600      &   -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39601      &   0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39602      &   0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39603      &   0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39604       data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39605      &   0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39606      &   -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39607      &   -0.614d0,3.548d0/
39608       data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39609      &   -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39610      &   -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39611      &   -0.48d0,3.401d0/
39612       data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39613      &   -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39614      &   0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39615      &   -0.079d0/
39616       data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39617      &   0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39618      &   0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39619      &   2.294d0/
39620       data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39621      &   -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39622      &   0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39623      &   0.814d0,1.531d0,0.124d0/
39624       data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39625      &   -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39626      &   -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39627      &   2.264d0,0.2675d0/
39628 c
39629       mu2=0.25d0
39630       lam2=0.232d0*0.232d0
39631 c
39632       if(p2.le.0.25d0) then
39633          s=log(log(q2/lam2)/log(mu2/lam2))
39634          lp1=0.d0
39635          lp2=0.d0
39636       else
39637          s=log(log(q2/lam2)/log(p2/lam2))
39638          lp1=log(p2/mu2)*log(p2/mu2)
39639          lp2=log(p2/mu2+log(p2/mu2))
39640       endif
39641 c
39642       alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39643       bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39644       a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39645      &  (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39646       b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39647      &  (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39648      &  (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39649       gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39650      &  (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39651      &  (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39652       ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39653      &  (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39654       gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39655      &  (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39656       gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39657      &  (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39658       ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39659      &  (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39660       gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39661      &  (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39662       upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39663 c
39664       alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39665       bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39666       a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39667      &  (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39668       b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39669      &  (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39670      &  (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39671       gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39672      &  (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39673      &  (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39674       ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39675      &  (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39676       gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39677      &  (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39678       gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39679      &  (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39680       ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39681      &  (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39682       gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39683      &  (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39684       dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39685 c
39686       alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39687       bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39688       a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39689      &  (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39690       b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39691      &  (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39692       gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39693      &  (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39694       ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39695      &  (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39696      &  (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39697       gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39698      &  (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39699       gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39700      &  (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39701      &  (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39702       ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39703      &  (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39704       gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39705      &  (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39706       gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39707 c
39708       s=log(log(q2/lam2)/log(mu2/lam2))
39709       suppr=1.d0/(1.d0+p2/0.59d0)**2
39710 c
39711       alp=ud2(1)
39712       bet=ud2(2)
39713       a=ud2(3)+ud2(4)*s
39714       ga=ud2(5)+ud2(6)*s**0.5
39715       gc=ud2(7)+ud2(8)*s
39716       b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39717       gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39718       gd=ud2(15)+ud2(16)*s
39719       ge=ud2(17)+ud2(18)*s
39720       gep=ud2(19)+ud2(20)*s
39721       udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39722 c
39723       alp=s2(1)
39724       bet=s2(2)
39725       a=s2(3)+s2(4)*s
39726       ga=s2(5)+s2(6)*s**0.5
39727       gc=s2(7)+s2(8)*s
39728       b=s2(9)+s2(10)*s+s2(11)*s**2
39729       gb=s2(12)+s2(13)*s+s2(14)*s**2
39730       gd=s2(15)+s2(16)*s
39731       ge=s2(17)+s2(18)*s
39732       gep=s2(19)+s2(20)*s
39733       spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39734 c
39735       alp=g2(1)
39736       bet=g2(2)
39737       a=g2(3)+g2(4)*s**0.5
39738       b=g2(5)+g2(6)*s**2
39739       gb=g2(7)+g2(8)*s
39740       ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39741       gc=g2(12)+g2(13)*s**2
39742       gd=g2(14)+g2(15)*s+g2(16)*s**2
39743       ge=g2(17)+g2(18)*s
39744       gep=g2(19)+g2(20)*s
39745       gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39746 c
39747       ugam=upart1+udpart2
39748       dgam=dspart1+udpart2
39749       sgam=dspart1+spart2
39750       ggam=gpart1+gpart2
39751 c
39752       end
39753
39754 *$ CREATE PHO_grsf1.FOR
39755 *COPY PHO_grsf1
39756 CDECK  ID>, PHO_grsf1
39757       DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39758      &                                ge,gep)
39759       implicit double precision (a-z)
39760       save
39761
39762       PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39763      &      s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39764      &      (1.d0-x)**gd
39765
39766       end
39767
39768 *$ CREATE PHO_grsf2.FOR
39769 *COPY PHO_grsf2
39770 CDECK  ID>, PHO_grsf2
39771       DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39772      &                                ge,gep)
39773       implicit double precision (a-z)
39774       save
39775
39776       PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39777      &      s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39778      &      (1.d0-x)**gd
39779
39780       end
39781
39782 *$ CREATE PHO_CKMTPA.FOR
39783 *COPY PHO_CKMTPA
39784 CDECK  ID>, PHO_CKMTPA
39785       SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39786 C**********************************************************************
39787 C
39788 C     PDF based on Regge theory, evolved with .... by ....
39789 C
39790 C     input: IPAR     2212   proton (not installed)
39791 C                      990   Pomeron
39792 C
39793 C     output: parameters of parametrization
39794 C
39795 C**********************************************************************
39796       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39797       SAVE
39798
39799       CHARACTER*8 PDFNA
39800
39801 C  input/output channels
39802       INTEGER LI,LO
39803       COMMON /POINOU/ LI,LO
39804
39805       REAL PROP(40),POMP(40)
39806       DATA PROP /
39807      & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39808      & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39809      & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39810      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39811      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39812      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39813      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39814      & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39815       DATA POMP /
39816      & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39817      & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39818      & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
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      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39823      & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39824
39825       IF(IPA.EQ.2212) THEN
39826         ALA  =PROP(1)
39827         Q2MI = PROP(39)
39828         Q2MA = PROP(40)
39829         PDFNA = 'CKMT-PRO'
39830       ELSE IF(IPA.EQ.990) THEN
39831         ALA  = POMP(1)
39832         Q2MI = POMP(39)
39833         Q2MA = POMP(40)
39834         PDFNA = 'CKMT-POM'
39835       ELSE
39836         WRITE(LO,'(1X,A,I7)')
39837      &    'PHO_CKMTPA:ERROR: invalid particle code',IPA
39838         STOP
39839       ENDIF
39840       XMI = 1.D-4
39841       XMA = 1.D0
39842       END
39843
39844 *$ CREATE PHO_CKMTPD.FOR
39845 *COPY PHO_CKMTPD
39846 CDECK  ID>, PHO_CKMTPD
39847       SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39848 C**********************************************************************
39849 C
39850 C     PDF based on Regge theory, evolved with .... by ....
39851 C
39852 C     input: IPAR     2212   proton (not installed)
39853 C                      990   Pomeron
39854 C
39855 C     output: PD(-6:6) x*f(x)  parton distribution functions
39856 C            (PDFLIB convention: d = PD(1), u = PD(2) )
39857 C
39858 C**********************************************************************
39859       SAVE
39860
39861 C  input/output channels
39862       INTEGER LI,LO
39863       COMMON /POINOU/ LI,LO
39864
39865       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP
39866       DIMENSION QQ(7)
39867
39868       Q2=SNGL(SCALE2)
39869       Q1S=Q2
39870       XX=SNGL(X)
39871 C  QCD lambda for evolution
39872       OWLAM = 0.23D0
39873       OWLAM2=OWLAM**2
39874 C  Q0**2 for evolution
39875       Q02 = 2.D0
39876 C
39877 C
39878 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39879 C                        q(6)=x*charm, q(7)=x*gluon
39880 C
39881       SB=0.
39882       IF(Q2-Q02) 1,1,2
39883     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39884     1 CONTINUE
39885       IF(IPAR.EQ.2212) THEN
39886 *       CALL PHO_CKMTPR(XX,SB,QQ
39887         WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39888         CALL PHO_ABORT
39889       ELSE
39890         CALL PHO_CKMTPO(XX,SB,QQ)
39891       ENDIF
39892 C
39893       PD(-6) = 0.D0
39894       PD(-5) = 0.D0
39895       PD(-4) = DBLE(QQ(6))
39896       PD(-3) = DBLE(QQ(3))
39897       PD(-2) = DBLE(QQ(4))
39898       PD(-1) = DBLE(QQ(5))
39899       PD(0)  = DBLE(QQ(7))
39900       PD(1)  = DBLE(QQ(2))
39901       PD(2)  = DBLE(QQ(1))
39902       PD(3)  = DBLE(QQ(3))
39903       PD(4)  = DBLE(QQ(6))
39904       PD(5)  = 0.D0
39905       PD(6)  = 0.D0
39906       IF(IPAR.EQ.990) THEN
39907         CDN = (PD(1)-PD(-1))/2.D0
39908         CUP = (PD(2)-PD(-2))/2.D0
39909         PD(-1) = PD(-1) + CDN
39910         PD(-2) = PD(-2) + CUP
39911         PD(1) = PD(-1)
39912         PD(2) = PD(-2)
39913       ENDIF
39914       END
39915
39916 *$ CREATE PHO_CKMTPO.FOR
39917 *COPY PHO_CKMTPO
39918 CDECK  ID>, PHO_CKMTPO
39919       SUBROUTINE PHO_CKMTPO(X,S,QQ)
39920 C**********************************************************************
39921 C
39922 C    calculation partons in Pomeron
39923 C
39924 C**********************************************************************
39925       SAVE
39926
39927       DIMENSION QQ(7)
39928
39929 C  input/output channels
39930       INTEGER LI,LO
39931       COMMON /POINOU/ LI,LO
39932
39933       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39934       EQUIVALENCE (GF(1,1,1),DL(1))
39935       DATA DELTA/.10/
39936
39937 C  RNG=  -.5
39938 C  DEU.NORM. QUARKS,GLUONS,NEW NORM   .6223E+00   .2754E+00   .1372E+01
39939 C  POM.NORM. QUARKS,GLUONS,ALL    .132E+00    .275E+00    .407E+00
39940       DATA (DL(K),K=    1,   85) /
39941      & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39942      & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39943      & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39944      & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39945      & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39946      & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39947      & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39948      & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39949      & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39950      & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39951      & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39952      & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39953      & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39954      & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39955      & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39956      & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39957      & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39958       DATA (DL(K),K=   86,  170) /
39959      & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39960      & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39961      & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39962      & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39963      & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39964      & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39965      & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39966      & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39967      & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39968      & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39969      & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39970      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39971      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39972      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39973      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39974      & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39975      & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39976       DATA (DL(K),K=  171,  255) /
39977      & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39978      & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39979      & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39980      & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39981      & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39982      & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39983      & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39984      & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39985      & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39986      & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39987      & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39988      & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39989      & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39990      & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39991      & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39992      & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39993      & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39994       DATA (DL(K),K=  256,  340) /
39995      & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39996      & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39997      & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39998      & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39999      & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
40000      & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
40001      & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
40002      & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
40003      & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40004      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40005      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40006      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40007      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40008      & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
40009      & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
40010      & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
40011      & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
40012       DATA (DL(K),K=  341,  425) /
40013      & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
40014      & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
40015      & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
40016      & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
40017      & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
40018      & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
40019      & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
40020      & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
40021      & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
40022      & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
40023      & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
40024      & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
40025      & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
40026      & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
40027      & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
40028      & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
40029      & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
40030       DATA (DL(K),K=  426,  510) /
40031      & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
40032      & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
40033      & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
40034      & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
40035      & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
40036      & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
40037      & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40038      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40039      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40040      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40041      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40042      & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
40043      & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
40044      & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
40045      & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
40046      & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
40047      & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
40048       DATA (DL(K),K=  511,  595) /
40049      & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
40050      & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
40051      & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
40052      & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
40053      & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
40054      & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
40055      & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
40056      & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
40057      & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
40058      & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
40059      & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
40060      & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
40061      & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
40062      & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
40063      & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
40064      & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
40065      & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
40066       DATA (DL(K),K=  596,  680) /
40067      & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
40068      & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
40069      & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
40070      & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
40071      & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40072      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40073      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40074      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40075      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40076      & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
40077      & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
40078      & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
40079      & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
40080      & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
40081      & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
40082      & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
40083      & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
40084       DATA (DL(K),K=  681,  765) /
40085      & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
40086      & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
40087      & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
40088      & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
40089      & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
40090      & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
40091      & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
40092      & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
40093      & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
40094      & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
40095      & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
40096      & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
40097      & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
40098      & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
40099      & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
40100      & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
40101      & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
40102       DATA (DL(K),K=  766,  850) /
40103      & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
40104      & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
40105      & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40106      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40107      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40108      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40109      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40110      & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
40111      & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
40112      & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
40113      & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
40114      & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
40115      & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
40116      & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
40117      & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
40118      & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
40119      & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
40120       DATA (DL(K),K=  851,  935) /
40121      & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
40122      & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
40123      & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
40124      & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
40125      & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
40126      & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
40127      & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
40128      & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
40129      & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
40130      & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
40131      & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
40132      & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
40133      & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
40134      & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
40135      & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
40136      & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
40137      & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
40138       DATA (DL(K),K=  936, 1020) /
40139      & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40140      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40141      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40142      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40143      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40144      & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
40145      & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
40146      & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
40147      & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
40148      & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
40149      & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
40150      & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
40151      & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
40152      & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
40153      & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
40154      & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
40155      & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
40156       DATA (DL(K),K= 1021, 1105) /
40157      & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
40158      & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
40159      & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
40160      & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
40161      & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
40162      & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
40163      & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
40164      & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
40165      & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
40166      & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
40167      & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
40168      & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
40169      & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
40170      & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
40171      & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
40172      & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40173      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40174       DATA (DL(K),K= 1106, 1190) /
40175      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40176      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40177      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40178      & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
40179      & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
40180      & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
40181      & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
40182      & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
40183      & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
40184      & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
40185      & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
40186      & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
40187      & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
40188      & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
40189      & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
40190      & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
40191      & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
40192       DATA (DL(K),K= 1191, 1275) /
40193      & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
40194      & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
40195      & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
40196      & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
40197      & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
40198      & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
40199      & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
40200      & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
40201      & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
40202      & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
40203      & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
40204      & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
40205      & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
40206      & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40207      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40208      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40209      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40210       DATA (DL(K),K= 1276, 1360) /
40211      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40212      & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
40213      & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
40214      & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
40215      & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
40216      & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
40217      & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
40218      & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
40219      & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
40220      & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
40221      & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
40222      & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
40223      & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
40224      & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
40225      & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
40226      & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
40227      & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
40228       DATA (DL(K),K= 1361, 1445) /
40229      & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
40230      & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
40231      & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
40232      & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
40233      & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
40234      & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
40235      & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
40236      & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
40237      & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
40238      & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
40239      & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
40240      & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40241      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40242      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40243      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40244      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40245      & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
40246       DATA (DL(K),K= 1446, 1530) /
40247      & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
40248      & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
40249      & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
40250      & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
40251      & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
40252      & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
40253      & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
40254      & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
40255      & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
40256      & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
40257      & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
40258      & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
40259      & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
40260      & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
40261      & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
40262      & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
40263      & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
40264       DATA (DL(K),K= 1531, 1615) /
40265      & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
40266      & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
40267      & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
40268      & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
40269      & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
40270      & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
40271      & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
40272      & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
40273      & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
40274      & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40275      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40276      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40277      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40278      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40279      & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
40280      & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
40281      & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
40282       DATA (DL(K),K= 1616, 1700) /
40283      & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
40284      & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
40285      & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
40286      & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
40287      & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
40288      & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
40289      & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
40290      & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
40291      & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
40292      & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
40293      & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
40294      & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
40295      & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
40296      & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
40297      & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
40298      & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
40299      & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
40300       DATA (DL(K),K= 1701, 1785) /
40301      & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
40302      & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
40303      & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
40304      & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
40305      & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
40306      & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
40307      & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
40308      & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40309      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40310      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40311      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40312      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40313      & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
40314      & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
40315      & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
40316      & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
40317      & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
40318       DATA (DL(K),K= 1786, 1870) /
40319      & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
40320      & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
40321      & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
40322      & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
40323      & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
40324      & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
40325      & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
40326      & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
40327      & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
40328      & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
40329      & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
40330      & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
40331      & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
40332      & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
40333      & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
40334      & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
40335      & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
40336       DATA (DL(K),K= 1871, 1955) /
40337      & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
40338      & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
40339      & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
40340      & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
40341      & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
40342      & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40343      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40344      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40345      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40346      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40347      & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
40348      & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
40349      & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
40350      & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
40351      & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
40352      & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
40353      & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
40354       DATA (DL(K),K= 1956, 2040) /
40355      & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
40356      & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
40357      & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
40358      & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
40359      & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
40360      & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
40361      & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
40362      & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
40363      & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
40364      & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
40365      & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
40366      & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
40367      & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
40368      & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
40369      & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
40370      & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
40371      & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
40372       DATA (DL(K),K= 2041, 2125) /
40373      & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
40374      & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
40375      & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
40376      & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40377      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40378      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40379      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40380      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40381      & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
40382      & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
40383      & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
40384      & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
40385      & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
40386      & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
40387      & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
40388      & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
40389      & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
40390       DATA (DL(K),K= 2126, 2210) /
40391      & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
40392      & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
40393      & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
40394      & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
40395      & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
40396      & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
40397      & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
40398      & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
40399      & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
40400      & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
40401      & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
40402      & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
40403      & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
40404      & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
40405      & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
40406      & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
40407      & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
40408       DATA (DL(K),K= 2211, 2295) /
40409      & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
40410      & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40411      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40412      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40413      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40414      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40415      & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
40416      & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
40417      & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
40418      & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
40419      & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
40420      & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
40421      & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
40422      & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
40423      & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
40424      & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
40425      & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
40426       DATA (DL(K),K= 2296, 2380) /
40427      & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
40428      & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
40429      & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
40430      & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
40431      & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
40432      & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
40433      & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
40434      & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
40435      & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
40436      & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
40437      & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
40438      & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
40439      & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
40440      & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
40441      & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
40442      & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
40443      & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40444       DATA (DL(K),K= 2381, 2465) /
40445      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40446      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40447      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40448      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40449      & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40450      & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40451      & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40452      & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40453      & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40454      & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40455      & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40456      & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40457      & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40458      & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40459      & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40460      & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40461      & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40462       DATA (DL(K),K= 2466, 2550) /
40463      & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40464      & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40465      & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40466      & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40467      & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40468      & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40469      & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40470      & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40471      & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40472      & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40473      & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40474      & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40475      & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40476      & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40477      & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40478      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40479      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40480       DATA (DL(K),K= 2551, 2635) /
40481      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40482      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40483      & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40484      & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40485      & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40486      & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40487      & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40488      & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40489      & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40490      & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40491      & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40492      & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40493      & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40494      & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40495      & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40496      & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40497      & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40498       DATA (DL(K),K= 2636, 2720) /
40499      & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40500      & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40501      & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40502      & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40503      & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40504      & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40505      & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40506      & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40507      & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40508      & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40509      & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40510      & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40511      & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40512      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40513      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40514      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40515      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40516       DATA (DL(K),K= 2721, 2805) /
40517      & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40518      & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40519      & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40520      & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40521      & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40522      & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40523      & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40524      & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40525      & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40526      & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40527      & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40528      & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40529      & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40530      & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40531      & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40532      & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40533      & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40534       DATA (DL(K),K= 2806, 2890) /
40535      & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40536      & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40537      & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40538      & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40539      & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40540      & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40541      & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40542      & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40543      & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40544      & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40545      & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40546      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40547      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40548      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40549      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40550      & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40551      & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40552       DATA (DL(K),K= 2891, 2975) /
40553      & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40554      & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40555      & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40556      & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40557      & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40558      & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40559      & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40560      & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40561      & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40562      & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40563      & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40564      & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40565      & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40566      & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40567      & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40568      & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40569      & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40570       DATA (DL(K),K= 2976, 3060) /
40571      & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40572      & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40573      & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40574      & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40575      & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40576      & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40577      & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40578      & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40579      & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40580      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40581      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40582      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40583      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40584      & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40585      & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40586      & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40587      & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40588       DATA (DL(K),K= 3061, 3145) /
40589      & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40590      & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40591      & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40592      & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40593      & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40594      & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40595      & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40596      & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40597      & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40598      & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40599      & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40600      & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40601      & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40602      & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40603      & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40604      & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40605      & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40606       DATA (DL(K),K= 3146, 3230) /
40607      & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40608      & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40609      & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40610      & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40611      & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40612      & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40613      & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40614      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40615      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40616      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40617      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40618      & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40619      & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40620      & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40621      & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40622      & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40623      & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40624       DATA (DL(K),K= 3231, 3315) /
40625      & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40626      & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40627      & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40628      & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40629      & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40630      & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40631      & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40632      & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40633      & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40634      & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40635      & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40636      & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40637      & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40638      & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40639      & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40640      & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40641      & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40642       DATA (DL(K),K= 3316, 3400) /
40643      & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40644      & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40645      & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40646      & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40647      & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40648      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40649      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40650      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40651      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40652      & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40653      & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40654      & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40655      & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40656      & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40657      & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40658      & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40659      & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40660       DATA (DL(K),K= 3401, 3485) /
40661      & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40662      & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40663      & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40664      & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40665      & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40666      & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40667      & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40668      & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40669      & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40670      & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40671      & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40672      & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40673      & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40674      & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40675      & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40676      & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40677      & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40678       DATA (DL(K),K= 3486, 3570) /
40679      & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40680      & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40681      & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40682      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40683      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40684      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40685      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40686      & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40687      & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40688      & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40689      & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40690      & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40691      & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40692      & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40693      & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40694      & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40695      & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40696       DATA (DL(K),K= 3571, 3655) /
40697      & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40698      & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40699      & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40700      & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40701      & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40702      & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40703      & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40704      & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40705      & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40706      & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40707      & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40708      & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40709      & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40710      & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40711      & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40712      & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40713      & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40714       DATA (DL(K),K= 3656, 3740) /
40715      & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40716      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40717      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40718      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40719      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40720      & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40721      & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40722      & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40723      & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40724      & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40725      & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40726      & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40727      & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40728      & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40729      & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40730      & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40731      & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40732       DATA (DL(K),K= 3741, 3825) /
40733      & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40734      & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40735      & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40736      & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40737      & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40738      & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40739      & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40740      & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40741      & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40742      & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40743      & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40744      & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40745      & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40746      & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40747      & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40748      & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40749      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40750       DATA (DL(K),K= 3826, 3910) /
40751      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40752      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40753      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40754      & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40755      & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40756      & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40757      & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40758      & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40759      & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40760      & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40761      & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40762      & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40763      & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40764      & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40765      & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40766      & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40767      & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40768       DATA (DL(K),K= 3911, 3995) /
40769      & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40770      & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40771      & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40772      & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40773      & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40774      & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40775      & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40776      & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40777      & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40778      & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40779      & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40780      & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40781      & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40782      & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40783      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40784      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40785      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40786       DATA (DL(K),K= 3996, 4000) /
40787      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40788
40789       DO 10 I=1,7
40790         QQ(I) = 0.
40791  10   CONTINUE
40792       IF(X.GT.0.9985) RETURN
40793
40794       IS = S/DELTA+1
40795       IS = MIN(IS,19)
40796       IS1 = IS+1
40797       DO 20 I=1,7
40798         IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40799         IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40800         DO 30 L=1,25
40801           F1(L)=GF(I,IS,L)
40802           F2(L)=GF(I,IS1,L)
40803  30     CONTINUE
40804         S1=(IS-1)*DELTA
40805         S2=S1+DELTA
40806         A1 = PHO_CKMTFV(X,F1)
40807         A2 = PHO_CKMTFV(X,F2)
40808         QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40809  19     CONTINUE
40810  20   CONTINUE
40811
40812       END
40813
40814 *$ CREATE PHO_CKMTFV.FOR
40815 *COPY PHO_CKMTFV
40816 CDECK  ID>, PHO_CKMTFV
40817       REAL FUNCTION PHO_CKMTFV(X,FVL)
40818 C**********************************************************************
40819 C
40820 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40821 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40822 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40823 C     IN MAIN ROUTINE.
40824 C
40825 C**********************************************************************
40826       SAVE
40827
40828       DIMENSION FVL(25),XGRID(25)
40829
40830 C  input/output channels
40831       INTEGER LI,LO
40832       COMMON /POINOU/ LI,LO
40833
40834       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40835      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40836
40837       PHO_CKMTFV=0.
40838       DO 1 I=1,NX
40839       IF(X.LT.XGRID(I)) GO TO 2
40840     1 CONTINUE
40841     2 I=I-1
40842       IF(I.EQ.0) THEN
40843          I=I+1
40844       ELSE IF(I.GT.23) THEN
40845          I=23
40846       ENDIF
40847       J=I+1
40848       K=J+1
40849       AXI=LOG(XGRID(I))
40850       BXI=LOG(1.-XGRID(I))
40851       AXJ=LOG(XGRID(J))
40852       BXJ=LOG(1.-XGRID(J))
40853       AXK=LOG(XGRID(K))
40854       BXK=LOG(1.-XGRID(K))
40855       FI=LOG(ABS(FVL(I)) +1.E-15)
40856       FJ=LOG(ABS(FVL(J)) +1.E-16)
40857       FK=LOG(ABS(FVL(K)) +1.E-17)
40858       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40859       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40860      $ BXI))/DET
40861       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40862       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40863       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40864      1RETURN
40865 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40866 C         WRITE(LO,2001) X,FVL
40867 C 2001    FORMAT(8E12.4)
40868 C         WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40869 C      ENDIF
40870       PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40871
40872       END
40873
40874 *$ CREATE PHO_SASGAM.FOR
40875 *COPY PHO_SASGAM
40876 CDECK  ID>, PHO_SASGAM
40877 C***********************************************************************
40878 C...SaSgam version 2 - parton distributions of the photon
40879 C...by Gerhard A. Schuler and Torbjorn Sjostrand
40880 C...For further information see Z. Phys. C68 (1995) 607
40881 C...and Phys. Lett. B376 (1996) 193.
40882
40883 C...18 January 1996: original code.
40884 C...22 July 1996: calculation of BETA moved in SASBEH.
40885
40886 C!!!Note that one further call parameter - IP2 - has been added
40887 C!!!to the SASGAM argument list compared with version 1.
40888
40889 C...The user should only need to call the SASGAM routine,
40890 C...which in turn calls the auxiliary routines SASVMD, SASANO,
40891 C...SASBEH and SASDIR. The package is self-contained.
40892
40893 C...One particular aspect of these parametrizations is that F2 for
40894 C...the photon is not obtained just as the charge-squared-weighted
40895 C...sum of quark distributions, but differ in the treatment of
40896 C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40897 C...the kinematics range of heavy-flavour production, but the same
40898 C...kinematics is not relevant e.g. for jet production) and, for the
40899 C...'MSbar' fits, in the addition of a Cgamma term related to the
40900 C...separation of direct processes. Schematically:
40901 C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40902 C...F2  = VMD (rho, omega, phi) + anomalous (d, u, s) +
40903 C...      Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40904 C...The J/psi and Upsilon states have not been included in the VMD sum,
40905 C...but low c and b masses in the other components should compensate
40906 C...for this in a duality sense.
40907
40908 C...The calling sequence is the following:
40909 C     CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40910 C...with the following declaration statement:
40911 C     DIMENSION XPDFGM(-6:6)
40912 C...and, optionally, further information in:
40913 C     COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40914 C    &XPDIR(-6:6)
40915 C     COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40916 C...Input:  ISET = 1 : SaS set 1D ('DIS',   Q0 = 0.6 GeV)
40917 C                = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40918 C                = 3 : SaS set 2D ('DIS',   Q0 =  2  GeV)
40919 C                = 4 : SaS set 2M ('MSbar', Q0 =  2  GeV)
40920 C           X : x value.
40921 C           Q2 : Q2 value.
40922 C           P2 : P2 value; should be = 0. for an on-shell photon.
40923 C           IP2 : scheme used to evaluate off-shell anomalous component.
40924 C               = 0 : recommended default, see = 7.
40925 C               = 1 : dipole dampening by integration; very time-consuming.
40926 C               = 2 : P_0^2 = max( Q_0^2, P^2 )
40927 C               = 3 : P_0^2 = Q_0^2 + P^2.
40928 C               = 4 : P_{eff} that preserves momentum sum.
40929 C               = 5 : P_{int} that preserves momentum and average
40930 C                     evolution range.
40931 C               = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40932 C               = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40933 C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40934 C           XPFDGM :  x times parton distribution functions of the photon,
40935 C               with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40936 C               6 = t (always empty!), - for antiquarks (result is same).
40937 C...The breakdown by component is stored in the commonblock SASCOM,
40938 C               with elements as above.
40939 C           XPVMD : rho, omega, phi VMD part only of output.
40940 C           XPANL : d, u, s anomalous part only of output.
40941 C           XPANH : c, b anomalous part only of output.
40942 C           XPBEH : c, b Bethe-Heitler part only of output.
40943 C           XPDIR : Cgamma (direct contribution) part only of output.
40944 C...The above arrays do not distinguish valence and sea contributions,
40945 C...although this information is available internally. The additional
40946 C...commonblock SASVAL provides the valence part only of the above
40947 C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40948 C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40949 C...and therefore not given doubly. VXPDGM gives the sum of valence
40950 C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40951 C...and so on, gives the sea part only.
40952 C***********************************************************************
40953
40954       SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40955 C...Purpose: to construct the F2 and parton distributions of the photon
40956 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40957 C...For F2, c and b are included by the Bethe-Heitler formula;
40958 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40959       SAVE
40960       DIMENSION XPDFGM(-6:6)
40961
40962 C  input/output channels
40963       INTEGER LI,LO
40964       COMMON /POINOU/ LI,LO
40965
40966       COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40967      &XPDIR(-6:6)
40968       COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40969 **sr
40970 C     SAVE /SASCOM/,/SASVAL/
40971 **
40972
40973 C...Temporary array.
40974       DIMENSION XPGA(-6:6), VXPGA(-6:6)
40975 C...Charm and bottom masses (low to compensate for J/psi etc.).
40976       DATA PMC/1.3/, PMB/4.6/
40977 C...alpha_em and alpha_em/(2*pi).
40978       DATA AEM/0.007297/, AEM2PI/0.0011614/
40979 C...Lambda value for 4 flavours.
40980       DATA ALAM/0.20/
40981 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40982       DATA FRACU/0.8/
40983 C...VMD couplings f_V**2/(4*pi).
40984       DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40985 C...Masses for rho (=omega) and phi.
40986       DATA PMRHO/0.770/, PMPHI/1.020/
40987 C...Number of points in integration for IP2=1.
40988       DATA NSTEP/100/
40989
40990 C...Reset output.
40991       F2GM=0.
40992       DO 100 KFL=-6,6
40993       XPDFGM(KFL)=0.
40994       XPVMD(KFL)=0.
40995       XPANL(KFL)=0.
40996       XPANH(KFL)=0.
40997       XPBEH(KFL)=0.
40998       XPDIR(KFL)=0.
40999       VXPVMD(KFL)=0.
41000       VXPANL(KFL)=0.
41001       VXPANH(KFL)=0.
41002       VXPDGM(KFL)=0.
41003   100 CONTINUE
41004
41005 C...Check that input sensible.
41006       IF(ISET.LE.0.OR.ISET.GE.5) THEN
41007         WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
41008         WRITE(LO,*) ' ISET = ',ISET
41009         STOP
41010       ENDIF
41011       IF(X.LE.0..OR.X.GT.1.) THEN
41012         WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
41013         WRITE(LO,*) ' X = ',X
41014         STOP
41015       ENDIF
41016
41017 C...Set Q0 cut-off parameter as function of set used.
41018       IF(ISET.LE.2) THEN
41019         Q0=0.6
41020       ELSE
41021         Q0=2.
41022       ENDIF
41023       Q02=Q0**2
41024
41025 C...Scale choice for off-shell photon; common factors.
41026       Q2A=Q2
41027       FACNOR=1.
41028       IF(IP2.EQ.1) THEN
41029         P2MX=P2+Q02
41030         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
41031         FACNOR=LOG(Q2/Q02)/NSTEP
41032       ELSEIF(IP2.EQ.2) THEN
41033         P2MX=MAX(P2,Q02)
41034       ELSEIF(IP2.EQ.3) THEN
41035         P2MX=P2+Q02
41036         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
41037       ELSEIF(IP2.EQ.4) THEN
41038         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41039      &  ((Q2+P2)*(Q02+P2)))
41040       ELSEIF(IP2.EQ.5) THEN
41041         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41042      &  ((Q2+P2)*(Q02+P2)))
41043         P2MX=Q0*SQRT(P2MXA)
41044         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
41045       ELSEIF(IP2.EQ.6) THEN
41046         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41047      &  ((Q2+P2)*(Q02+P2)))
41048         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
41049       ELSE
41050         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41051      &  ((Q2+P2)*(Q02+P2)))
41052         P2MX=Q0*SQRT(P2MXA)
41053         P2MXB=P2MX
41054         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
41055         P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
41056         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
41057       ENDIF
41058
41059 C...Call VMD parametrization for d quark and use to give rho, omega,
41060 C...phi. Note dipole dampening for off-shell photon.
41061       CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41062       XFVAL=VXPGA(1)
41063       XPGA(1)=XPGA(2)
41064       XPGA(-1)=XPGA(-2)
41065       FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
41066       FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
41067       DO 110 KFL=-5,5
41068       XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
41069   110 CONTINUE
41070       XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
41071       XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
41072       XPVMD(3)=XPVMD(3)+FACS*XFVAL
41073       XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
41074       XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
41075       XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
41076       VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
41077       VXPVMD(2)=FRACU*FACUD*XFVAL
41078       VXPVMD(3)=FACS*XFVAL
41079       VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
41080       VXPVMD(-2)=FRACU*FACUD*XFVAL
41081       VXPVMD(-3)=FACS*XFVAL
41082
41083       IF(IP2.NE.1) THEN
41084 C...Anomalous parametrizations for different strategies
41085 C...for off-shell photons; except full integration.
41086
41087 C...Call anomalous parametrization for d + u + s.
41088         CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41089         DO 120 KFL=-5,5
41090         XPANL(KFL)=FACNOR*XPGA(KFL)
41091         VXPANL(KFL)=FACNOR*VXPGA(KFL)
41092   120   CONTINUE
41093
41094 C...Call anomalous parametrization for c and b.
41095         CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41096         DO 130 KFL=-5,5
41097         XPANH(KFL)=FACNOR*XPGA(KFL)
41098         VXPANH(KFL)=FACNOR*VXPGA(KFL)
41099   130   CONTINUE
41100         CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41101         DO 140 KFL=-5,5
41102         XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
41103         VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
41104   140   CONTINUE
41105
41106       ELSE
41107 C...Special option: loop over flavours and integrate over k2.
41108         DO 170 KF=1,5
41109         DO 160 ISTEP=1,NSTEP
41110         Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
41111         IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
41112      &  (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
41113         CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
41114         FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
41115         IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
41116         IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
41117         DO 150 KFL=-5,5
41118         IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
41119         IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
41120         IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
41121         IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
41122   150   CONTINUE
41123   160   CONTINUE
41124   170   CONTINUE
41125       ENDIF
41126
41127 C...Call Bethe-Heitler term expression for charm and bottom.
41128       CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
41129       XPBEH(4)=XPBH
41130       XPBEH(-4)=XPBH
41131       CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
41132       XPBEH(5)=XPBH
41133       XPBEH(-5)=XPBH
41134
41135 C...For MSbar subtraction call C^gamma term expression for d, u, s.
41136       IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
41137         CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41138         DO 180 KFL=-5,5
41139         XPDIR(KFL)=XPGA(KFL)
41140   180   CONTINUE
41141       ENDIF
41142
41143 C...Store result in output array.
41144       DO 190 KFL=-5,5
41145       CHSQ=1./9.
41146       IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
41147       XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
41148       IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
41149       XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
41150       VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
41151   190 CONTINUE
41152
41153       RETURN
41154       END
41155
41156 C*********************************************************************
41157
41158 *$ CREATE PHO_SASVMD.FOR
41159 *COPY PHO_SASVMD
41160 CDECK  ID>, PHO_SASVMD
41161       SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
41162 C...Purpose: to evaluate the VMD parton distributions of a photon,
41163 C...evolved homogeneously from an initial scale P2 to Q2.
41164 C...Does not include dipole suppression factor.
41165 C...ISET is parton distribution set, see above;
41166 C...additionally ISET=0 is used for the evolution of an anomalous photon
41167 C...which branched at a scale P2 and then evolved homogeneously to Q2.
41168 C...ALAM is the 4-flavour Lambda, which is automatically converted
41169 C...to 3- and 5-flavour equivalents as needed.
41170       SAVE
41171       DIMENSION XPGA(-6:6), VXPGA(-6:6)
41172
41173 C  input/output channels
41174       INTEGER LI,LO
41175       COMMON /POINOU/ LI,LO
41176
41177       DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
41178
41179 C...Reset output.
41180       DO 100 KFL=-6,6
41181       XPGA(KFL)=0.
41182       VXPGA(KFL)=0.
41183   100 CONTINUE
41184       KFA=IABS(KF)
41185
41186 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
41187       ALAM3=ALAM*(PMC/ALAM)**(2./27.)
41188       ALAM5=ALAM*(ALAM/PMB)**(2./23.)
41189       P2EFF=MAX(P2,1.2*ALAM3**2)
41190       IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
41191       IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
41192       Q2EFF=MAX(Q2,P2EFF)
41193
41194 C...Find number of flavours at lower and upper scale.
41195       NFP=4
41196       IF(P2EFF.LT.PMC**2) NFP=3
41197       IF(P2EFF.GT.PMB**2) NFP=5
41198       NFQ=4
41199       IF(Q2EFF.LT.PMC**2) NFQ=3
41200       IF(Q2EFF.GT.PMB**2) NFQ=5
41201
41202 C...Find s as sum of 3-, 4- and 5-flavour parts.
41203       S=0.
41204       IF(NFP.EQ.3) THEN
41205         Q2DIV=PMC**2
41206         IF(NFQ.EQ.3) Q2DIV=Q2EFF
41207         S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
41208       ENDIF
41209       IF(NFP.LE.4.AND.NFQ.GE.4) THEN
41210         P2DIV=P2EFF
41211         IF(NFP.EQ.3) P2DIV=PMC**2
41212         Q2DIV=Q2EFF
41213         IF(NFQ.EQ.5) Q2DIV=PMB**2
41214         S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
41215       ENDIF
41216       IF(NFQ.EQ.5) THEN
41217         P2DIV=PMB**2
41218         IF(NFP.EQ.5) P2DIV=P2EFF
41219         S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
41220       ENDIF
41221
41222 C...Calculate frequent combinations of x and s.
41223       X1=1.-X
41224       XL=-LOG(X)
41225       S2=S**2
41226       S3=S**3
41227       S4=S**4
41228
41229 C...Evaluate homogeneous anomalous parton distributions below or
41230 C...above threshold.
41231       IF(ISET.EQ.0) THEN
41232       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41233      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41234         XVAL = X * 1.5 * (X**2+X1**2)
41235         XGLU = 0.
41236         XSEA = 0.
41237       ELSE
41238         XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
41239      &  (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
41240      &  X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
41241         XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
41242      &  X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
41243      &  ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
41244         XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
41245      &  X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
41246      &  ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
41247      &  (2.*X-1.)*X*XL**2)
41248       ENDIF
41249
41250 C...Evaluate set 1D parton distributions below or above threshold.
41251       ELSEIF(ISET.EQ.1) THEN
41252       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41253      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41254         XVAL = 1.294 * X**0.80 * X1**0.76
41255         XGLU = 1.273 * X**0.40 * X1**1.76
41256         XSEA = 0.100 * X1**3.76
41257       ELSE
41258         XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
41259      &  X1**(0.76+0.667*S) * XL**(2.*S)
41260         XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
41261      &  X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
41262      &  1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
41263         XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
41264      &  X**(-7.32*S2/(1.+10.3*S2)) *
41265      &  X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
41266         XSEA0 = 0.100 * X1**3.76
41267       ENDIF
41268
41269 C...Evaluate set 1M parton distributions below or above threshold.
41270       ELSEIF(ISET.EQ.2) THEN
41271       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41272      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41273         XVAL = 0.8477 * X**0.51 * X1**1.37
41274         XGLU = 3.42 * X**0.255 * X1**2.37
41275         XSEA = 0.
41276       ELSE
41277         XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
41278      &  * X1**1.37 * XL**(2.667*S)
41279         XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
41280      &  X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
41281      &  XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
41282      &  X1**(2.37+3.*S)
41283         XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
41284      &  X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
41285      &  XL**(2.8*S)
41286         XSEA0 = 0.
41287       ENDIF
41288
41289 C...Evaluate set 2D parton distributions below or above threshold.
41290       ELSEIF(ISET.EQ.3) THEN
41291       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41292      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41293         XVAL = X**0.46 * X1**0.64 + 0.76 * X
41294         XGLU = 1.925 * X1**2
41295         XSEA = 0.242 * X1**4
41296       ELSE
41297         XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
41298      &  * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
41299      &  (0.76+0.4*S) * X * X1**(2.667*S)
41300         XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
41301      &  EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
41302      &  * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
41303         XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
41304      &  X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
41305         XSEA0 = 0.242 * X1**4
41306       ENDIF
41307
41308 C...Evaluate set 2M parton distributions below or above threshold.
41309       ELSEIF(ISET.EQ.4) THEN
41310       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41311      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41312         XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
41313         XGLU = 1.808 * X1**2
41314         XSEA = 0.209 * X1**4
41315       ELSE
41316         XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
41317      &  X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
41318      &  X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
41319      &  (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
41320         XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
41321      &  X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
41322      &  X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
41323      &  XL**(10.9*S/(1.+2.5*S))
41324         XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
41325      &  X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
41326      &  X1**(4.+S) * XL**(0.45*S)
41327         XSEA0 = 0.209 * X1**4
41328       ENDIF
41329       ENDIF
41330
41331 C...Threshold factors for c and b sea.
41332       SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41333       XCHM=0.
41334       IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41335         SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41336         IF(ISET.EQ.0) THEN
41337           XCHM=XSEA*(1.-(SCH/SLL)**2)
41338         ELSE
41339           XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
41340         ENDIF
41341       ENDIF
41342       XBOT=0.
41343       IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41344         SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41345         IF(ISET.EQ.0) THEN
41346           XBOT=XSEA*(1.-(SBT/SLL)**2)
41347         ELSE
41348           XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
41349         ENDIF
41350       ENDIF
41351
41352 C...Fill parton distributions.
41353       XPGA(0)=XGLU
41354       XPGA(1)=XSEA
41355       XPGA(2)=XSEA
41356       XPGA(3)=XSEA
41357       XPGA(4)=XCHM
41358       XPGA(5)=XBOT
41359       XPGA(KFA)=XPGA(KFA)+XVAL
41360       DO 110 KFL=1,5
41361       XPGA(-KFL)=XPGA(KFL)
41362   110 CONTINUE
41363       VXPGA(KFA)=XVAL
41364       VXPGA(-KFA)=XVAL
41365
41366       RETURN
41367       END
41368
41369 C*********************************************************************
41370
41371 *$ CREATE PHO_SASANO.FOR
41372 *COPY PHO_SASANO
41373 CDECK  ID>, PHO_SASANO
41374       SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
41375 C...Purpose: to evaluate the parton distributions of the anomalous
41376 C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
41377 C...to Q2.
41378 C...KF=0 gives the sum over (up to) 5 flavours,
41379 C...KF<0 limits to flavours up to abs(KF),
41380 C...KF>0 is for flavour KF only.
41381 C...ALAM is the 4-flavour Lambda, which is automatically converted
41382 C...to 3- and 5-flavour equivalents as needed.
41383       SAVE
41384
41385 C  input/output channels
41386       INTEGER LI,LO
41387       COMMON /POINOU/ LI,LO
41388
41389       DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
41390       DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
41391
41392 C...Reset output.
41393       DO 100 KFL=-6,6
41394       XPGA(KFL)=0.
41395       VXPGA(KFL)=0.
41396   100 CONTINUE
41397       IF(Q2.LE.P2) RETURN
41398       KFA=IABS(KF)
41399
41400 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
41401       ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
41402       ALAMSQ(4)=ALAM**2
41403       ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
41404       P2EFF=MAX(P2,1.2*ALAMSQ(3))
41405       IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
41406       IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
41407       Q2EFF=MAX(Q2,P2EFF)
41408       XL=-LOG(X)
41409
41410 C...Find number of flavours at lower and upper scale.
41411       NFP=4
41412       IF(P2EFF.LT.PMC**2) NFP=3
41413       IF(P2EFF.GT.PMB**2) NFP=5
41414       NFQ=4
41415       IF(Q2EFF.LT.PMC**2) NFQ=3
41416       IF(Q2EFF.GT.PMB**2) NFQ=5
41417
41418 C...Define range of flavour loop.
41419       IF(KF.EQ.0) THEN
41420         KFLMN=1
41421         KFLMX=5
41422       ELSEIF(KF.LT.0) THEN
41423         KFLMN=1
41424         KFLMX=KFA
41425       ELSE
41426         KFLMN=KFA
41427         KFLMX=KFA
41428       ENDIF
41429
41430 C...Loop over flavours the photon can branch into.
41431       DO 110 KFL=KFLMN,KFLMX
41432
41433 C...Light flavours: calculate t range and (approximate) s range.
41434       IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
41435         TDIFF=LOG(Q2EFF/P2EFF)
41436         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41437      &  LOG(P2EFF/ALAMSQ(NFQ)))
41438         IF(NFQ.GT.NFP) THEN
41439           Q2DIV=PMB**2
41440           IF(NFQ.EQ.4) Q2DIV=PMC**2
41441           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41442      &    LOG(P2EFF/ALAMSQ(NFQ)))
41443           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41444      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
41445           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41446         ENDIF
41447         IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41448           Q2DIV=PMC**2
41449           SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41450      &    LOG(P2EFF/ALAMSQ(4)))
41451           SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41452      &    LOG(P2EFF/ALAMSQ(3)))
41453           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41454         ENDIF
41455
41456 C...u and s quark do not need a separate treatment when d has been done.
41457       ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41458
41459 C...Charm: as above, but only include range above c threshold.
41460       ELSEIF(KFL.EQ.4) THEN
41461         IF(Q2.LE.PMC**2) GOTO 110
41462         P2EFF=MAX(P2EFF,PMC**2)
41463         Q2EFF=MAX(Q2EFF,P2EFF)
41464         TDIFF=LOG(Q2EFF/P2EFF)
41465         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41466      &  LOG(P2EFF/ALAMSQ(NFQ)))
41467         IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41468           Q2DIV=PMB**2
41469           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41470      &    LOG(P2EFF/ALAMSQ(NFQ)))
41471           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41472      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
41473           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41474         ENDIF
41475
41476 C...Bottom: as above, but only include range above b threshold.
41477       ELSEIF(KFL.EQ.5) THEN
41478         IF(Q2.LE.PMB**2) GOTO 110
41479         P2EFF=MAX(P2EFF,PMB**2)
41480         Q2EFF=MAX(Q2,P2EFF)
41481         TDIFF=LOG(Q2EFF/P2EFF)
41482         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41483      &  LOG(P2EFF/ALAMSQ(NFQ)))
41484       ENDIF
41485
41486 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41487       CHSQ=1./9.
41488       IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41489       FAC=AEM2PI*2.*CHSQ*TDIFF
41490
41491 C...Evaluate parton distributions (normalized to unit momentum sum).
41492       IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41493         XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41494      &  (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41495      &  1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41496      &  X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41497         XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41498      &  X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41499      &  ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41500         XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41501      &  X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41502      &  ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41503      &  (2.*X-1.)*X*XL**2)
41504
41505 C...Threshold factors for c and b sea.
41506         SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41507         XCHM=0.
41508         IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41509           SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41510           XCHM=XSEA*(1.-(SCH/SLL)**3)
41511         ENDIF
41512         XBOT=0.
41513         IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41514           SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41515           XBOT=XSEA*(1.-(SBT/SLL)**3)
41516         ENDIF
41517       ENDIF
41518
41519 C...Add contribution of each valence flavour.
41520       XPGA(0)=XPGA(0)+FAC*XGLU
41521       XPGA(1)=XPGA(1)+FAC*XSEA
41522       XPGA(2)=XPGA(2)+FAC*XSEA
41523       XPGA(3)=XPGA(3)+FAC*XSEA
41524       XPGA(4)=XPGA(4)+FAC*XCHM
41525       XPGA(5)=XPGA(5)+FAC*XBOT
41526       XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41527       VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41528   110 CONTINUE
41529       DO 120 KFL=1,5
41530       XPGA(-KFL)=XPGA(KFL)
41531       VXPGA(-KFL)=VXPGA(KFL)
41532   120 CONTINUE
41533
41534       END
41535
41536 C*********************************************************************
41537
41538 *$ CREATE PHO_SASBEH.FOR
41539 *COPY PHO_SASBEH
41540 CDECK  ID>, PHO_SASBEH
41541       SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41542 C...Purpose: to evaluate the Bethe-Heitler cross section for
41543 C...heavy flavour production.
41544       SAVE
41545       DATA AEM2PI/0.0011614/
41546
41547 C...Reset output.
41548       XPBH=0.
41549       SIGBH=0.
41550
41551 C...Check kinematics limits.
41552       IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41553       W2=Q2*(1.-X)/X-P2
41554       BETA2=1.-4.*PM2/W2
41555       IF(BETA2.LT.1E-10) RETURN
41556       BETA=SQRT(BETA2)
41557       RMQ=4.*PM2/Q2
41558
41559 C...Simple case: P2 = 0.
41560       IF(P2.LT.1E-4) THEN
41561         IF(BETA.LT.0.99) THEN
41562           XBL=LOG((1.+BETA)/(1.-BETA))
41563         ELSE
41564           XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41565         ENDIF
41566         SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41567      &  XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41568
41569 C...Complicated case: P2 > 0, based on approximation of
41570 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41571       ELSE
41572         RPQ=1.-4.*X**2*P2/Q2
41573         IF(RPQ.GT.1E-10) THEN
41574           RPBE=SQRT(RPQ*BETA2)
41575           IF(RPBE.LT.0.99) THEN
41576             XBL=LOG((1.+RPBE)/(1.-RPBE))
41577             XBI=2.*RPBE/(1.-RPBE**2)
41578           ELSE
41579             RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41580             XBL=LOG((1.+RPBE)**2/RPBESN)
41581             XBI=2.*RPBE/RPBESN
41582           ENDIF
41583           SIGBH=BETA*(6.*X*(1.-X)-1.)+
41584      &    XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41585      &    XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41586         ENDIF
41587       ENDIF
41588
41589 C...Multiply by charge-squared etc. to get parton distribution.
41590       CHSQ=1./9.
41591       IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41592       XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41593
41594       END
41595
41596 C*********************************************************************
41597
41598 *$ CREATE PHO_SASDIR.FOR
41599 *COPY PHO_SASDIR
41600 CDECK  ID>, PHO_SASDIR
41601       SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41602 C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41603 C...as needed in MSbar parametrizations.
41604       SAVE
41605       DIMENSION XPGA(-6:6)
41606       DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41607
41608 C...Reset output.
41609       DO 100 KFL=-6,6
41610       XPGA(KFL)=0.
41611   100 CONTINUE
41612
41613 C...Evaluate common x-dependent expression.
41614       XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41615       CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41616
41617 C...d, u, s part by simple charge factor.
41618       XPGA(1)=(1./9.)*CGAM
41619       XPGA(2)=(4./9.)*CGAM
41620       XPGA(3)=(1./9.)*CGAM
41621
41622 C...Also fill for antiquarks.
41623       DO 110 KF=1,5
41624       XPGA(-KF)=XPGA(KF)
41625   110 CONTINUE
41626
41627       END
41628
41629 *$ CREATE PHO_PHGAL.FOR
41630 *COPY PHO_PHGAL
41631 CDECK  ID>, PHO_PHGAL
41632       SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41633 C***********************************************************************
41634 C
41635 C     photon parton densities with built-in momentum sum rule and
41636 C     Regge-based low-x behaviour
41637 C
41638 C     H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41639 C     e-Print Archive: hep-ph/9711355
41640 C
41641 C     code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41642 C
41643 C***********************************************************************
41644       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41645       SAVE
41646
41647       PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41648       DOUBLE PRECISION
41649      &       XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41650      &       XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41651
41652       DIMENSION NA(NARG)
41653
41654       DATA ZEROD/0.D0/
41655
41656 C...100 x values; in (D-4,.77) log spaced (78 points)
41657 C...              in (.78,.995) lineary spaced (22 points)
41658       DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41659       DATA XT/
41660      &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41661      &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41662      &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41663      &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41664      &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41665      &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41666      &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41667      &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41668      &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41669      &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41670      &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41671      &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41672      &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41673      &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41674      &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41675      &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41676      &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41677
41678 C...place for DATA blocks
41679       DATA (XPV(I,1,0),I=1,100)/
41680      &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41681      &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41682      &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41683      &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41684      &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41685      &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41686      &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41687      &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41688      &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41689      &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41690      &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41691      &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41692      &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41693      &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41694      &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41695      &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41696      &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41697       DATA (XPV(I,1,1),I=1,100)/
41698      &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41699      &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41700      &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41701      &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41702      &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41703      &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41704      &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41705      &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41706      &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41707      &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41708      &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41709      &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41710      &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41711      &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41712      &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41713      &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41714      &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41715       DATA (XPV(I,1,2),I=1,100)/
41716      &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41717      &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41718      &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41719      &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41720      &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41721      &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41722      &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41723      &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41724      &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41725      &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41726      &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41727      &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41728      &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41729      &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41730      &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41731      &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41732      &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41733       DATA (XPV(I,1,3),I=1,100)/
41734      &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41735      &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41736      &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41737      &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41738      &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41739      &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41740      &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41741      &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41742      &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41743      &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41744      &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41745      &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41746      &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41747      &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41748      &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41749      &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41750      &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41751       DATA (XPV(I,1,4),I=1,100)/
41752      &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41753      &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41754      &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41755      &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41756      &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41757      &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41758      &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41759      &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41760      &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41761      &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41762      &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41763      &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41764      &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41765      &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41766      &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41767      &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41768      &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41769       DATA (XPV(I,2,0),I=1,100)/
41770      &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41771      &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41772      &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41773      &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41774      &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41775      &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41776      &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41777      &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41778      &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41779      &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41780      &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41781      &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41782      &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41783      &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41784      &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41785      &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41786      &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41787       DATA (XPV(I,2,1),I=1,100)/
41788      &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41789      &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41790      &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41791      &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41792      &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41793      &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41794      &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41795      &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41796      &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41797      &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41798      &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41799      &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41800      &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41801      &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41802      &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41803      &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41804      &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41805       DATA (XPV(I,2,2),I=1,100)/
41806      &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41807      &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41808      &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41809      &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41810      &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41811      &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41812      &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41813      &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41814      &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41815      &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41816      &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41817      &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41818      &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41819      &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41820      &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41821      &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41822      &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41823       DATA (XPV(I,2,3),I=1,100)/
41824      &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41825      &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41826      &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41827      &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41828      &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41829      &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41830      &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41831      &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41832      &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41833      &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41834      &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41835      &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41836      &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41837      &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41838      &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41839      &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41840      &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41841       DATA (XPV(I,2,4),I=1,100)/
41842      &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41843      &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41844      &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41845      &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41846      &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41847      &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41848      &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41849      &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41850      &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41851      &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41852      &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41853      &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41854      &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41855      &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41856      &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41857      &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41858      &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41859       DATA (XPV(I,3,0),I=1,100)/
41860      &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41861      &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41862      &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41863      &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41864      &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41865      &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41866      &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41867      &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41868      &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41869      &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41870      &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41871      &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41872      &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41873      &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41874      &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41875      &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41876      &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41877       DATA (XPV(I,3,1),I=1,100)/
41878      &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41879      &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41880      &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41881      &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41882      &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41883      &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41884      &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41885      &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41886      &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41887      &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41888      &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41889      &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41890      &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41891      &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41892      &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41893      &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41894      &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41895       DATA (XPV(I,3,2),I=1,100)/
41896      &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41897      &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41898      &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41899      &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41900      &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41901      &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41902      &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41903      &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41904      &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41905      &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41906      &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41907      &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41908      &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41909      &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41910      &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41911      &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41912      &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41913       DATA (XPV(I,3,3),I=1,100)/
41914      &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41915      &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41916      &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41917      &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41918      &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41919      &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41920      &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41921      &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41922      &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41923      &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41924      &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41925      &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41926      &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41927      &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41928      &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41929      &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41930      &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41931       DATA (XPV(I,3,4),I=1,100)/
41932      &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41933      &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41934      &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41935      &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41936      &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41937      &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41938      &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41939      &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41940      &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41941      &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41942      &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41943      &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41944      &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41945      &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41946      &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41947      &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41948      &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41949       DATA (XPV(I,4,0),I=1,100)/
41950      &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41951      &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41952      &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41953      &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41954      &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41955      &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41956      &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41957      &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41958      &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41959      &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41960      &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41961      &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41962      &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41963      &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41964      &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41965      &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41966      &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41967       DATA (XPV(I,4,1),I=1,100)/
41968      &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41969      &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41970      &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41971      &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41972      &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41973      &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41974      &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41975      &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41976      &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41977      &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41978      &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41979      &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41980      &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41981      &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41982      &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41983      &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41984      &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41985       DATA (XPV(I,4,2),I=1,100)/
41986      &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41987      &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41988      &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41989      &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41990      &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41991      &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41992      &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41993      &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41994      &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41995      &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41996      &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41997      &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41998      &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41999      &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
42000      &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
42001      &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
42002      &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
42003       DATA (XPV(I,4,3),I=1,100)/
42004      &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
42005      &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
42006      &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
42007      &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
42008      &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
42009      &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
42010      &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
42011      &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
42012      &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
42013      &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
42014      &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
42015      &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
42016      &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
42017      &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
42018      &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
42019      &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
42020      &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
42021       DATA (XPV(I,4,4),I=1,100)/
42022      &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
42023      &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
42024      &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
42025      &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
42026      &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
42027      &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
42028      &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
42029      &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
42030      &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
42031      &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
42032      &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
42033      &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
42034      &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
42035      &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
42036      &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
42037      &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
42038      &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
42039       DATA (XPV(I,5,0),I=1,100)/
42040      &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
42041      &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
42042      &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
42043      &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
42044      &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
42045      &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
42046      &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
42047      &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
42048      &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
42049      &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
42050      &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
42051      &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
42052      &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
42053      &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
42054      &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
42055      &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
42056      &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
42057       DATA (XPV(I,5,1),I=1,100)/
42058      &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
42059      &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
42060      &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
42061      &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
42062      &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
42063      &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
42064      &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
42065      &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
42066      &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
42067      &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
42068      &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
42069      &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
42070      &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
42071      &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
42072      &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
42073      &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
42074      &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
42075       DATA (XPV(I,5,2),I=1,100)/
42076      &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
42077      &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
42078      &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
42079      &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
42080      &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
42081      &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
42082      &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
42083      &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
42084      &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
42085      &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
42086      &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
42087      &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
42088      &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
42089      &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
42090      &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
42091      &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
42092      &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
42093       DATA (XPV(I,5,3),I=1,100)/
42094      &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
42095      &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
42096      &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
42097      &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
42098      &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
42099      &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
42100      &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
42101      &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
42102      &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
42103      &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
42104      &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
42105      &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
42106      &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
42107      &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
42108      &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
42109      &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
42110      &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
42111       DATA (XPV(I,5,4),I=1,100)/
42112      &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
42113      &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
42114      &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
42115      &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
42116      &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
42117      &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
42118      &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
42119      &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
42120      &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
42121      &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
42122      &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
42123      &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
42124      &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
42125      &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
42126      &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
42127      &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
42128      &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
42129       DATA (XPV(I,6,0),I=1,100)/
42130      &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
42131      &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
42132      &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
42133      &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
42134      &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
42135      &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
42136      &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
42137      &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
42138      &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
42139      &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
42140      &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
42141      &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
42142      &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
42143      &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
42144      &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
42145      &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
42146      &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
42147       DATA (XPV(I,6,1),I=1,100)/
42148      &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
42149      &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
42150      &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
42151      &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
42152      &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
42153      &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
42154      &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
42155      &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
42156      &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
42157      &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
42158      &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
42159      &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
42160      &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
42161      &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
42162      &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
42163      &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
42164      &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
42165       DATA (XPV(I,6,2),I=1,100)/
42166      &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
42167      &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
42168      &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
42169      &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
42170      &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
42171      &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
42172      &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
42173      &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
42174      &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
42175      &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
42176      &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
42177      &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
42178      &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
42179      &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
42180      &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
42181      &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
42182      &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
42183       DATA (XPV(I,6,3),I=1,100)/
42184      &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
42185      &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
42186      &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
42187      &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
42188      &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
42189      &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
42190      &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
42191      &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
42192      &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
42193      &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
42194      &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
42195      &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
42196      &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
42197      &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
42198      &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
42199      &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
42200      &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
42201       DATA (XPV(I,6,4),I=1,100)/
42202      &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
42203      &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
42204      &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
42205      &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
42206      &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
42207      &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
42208      &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
42209      &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
42210      &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
42211      &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
42212      &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
42213      &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
42214      &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
42215      &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
42216      &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
42217      &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
42218      &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
42219       DATA (XPV(I,7,0),I=1,100)/
42220      &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
42221      &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
42222      &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
42223      &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
42224      &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
42225      &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
42226      &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
42227      &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
42228      &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
42229      &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
42230      &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
42231      &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
42232      &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
42233      &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
42234      &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
42235      &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
42236      &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
42237       DATA (XPV(I,7,1),I=1,100)/
42238      &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
42239      &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
42240      &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
42241      &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
42242      &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
42243      &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
42244      &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
42245      &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
42246      &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
42247      &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
42248      &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
42249      &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
42250      &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
42251      &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
42252      &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
42253      &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
42254      &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
42255       DATA (XPV(I,7,2),I=1,100)/
42256      &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
42257      &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
42258      &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
42259      &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
42260      &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
42261      &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
42262      &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
42263      &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
42264      &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
42265      &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
42266      &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
42267      &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
42268      &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
42269      &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
42270      &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
42271      &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
42272      &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
42273       DATA (XPV(I,7,3),I=1,100)/
42274      &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
42275      &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
42276      &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
42277      &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
42278      &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
42279      &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
42280      &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
42281      &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
42282      &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
42283      &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
42284      &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
42285      &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
42286      &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
42287      &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
42288      &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
42289      &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
42290      &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
42291       DATA (XPV(I,7,4),I=1,100)/
42292      &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
42293      &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
42294      &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
42295      &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
42296      &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
42297      &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
42298      &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
42299      &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
42300      &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
42301      &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
42302      &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
42303      &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
42304      &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
42305      &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
42306      &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
42307      &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
42308      &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
42309
42310 C..fetching pdfs
42311       DO  5 IP=-6,6
42312         XPDF(IP)=ZEROD
42313  5    CONTINUE
42314       DO 2 I=1,IX
42315         ENT(I)=LOG10(XT(I))
42316   2   CONTINUE
42317       NA(1)=IX
42318       NA(2)=IQ
42319       DO 3 I=1,IQ
42320         ENT(IX+I)=LOG10(Q2T(I))
42321    3  CONTINUE
42322       ARG(1)=LOG10(X)
42323       ARG(2)=LOG10(Q2)
42324 C..various flavours (u-->2,d-->1)
42325       XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
42326       XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
42327       XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
42328       XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
42329       XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
42330       DO 21 JF=1,4
42331         XPDF(-JF)=XPDF(JF)
42332  21   CONTINUE
42333
42334       END
42335
42336 *$ CREATE PHO_DBFINT.FOR
42337 *COPY PHO_DBFINT
42338 CDECK  ID>, PHO_DBFINT
42339       DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
42340 C***********************************************************************
42341 C
42342 C     routine based on CERN library E104
42343 C
42344 C     multi-dimensional interpolation routine, needed for PHOJET
42345 C     internal cross section tables and several PDF sets (GRV98 and AGL)
42346 C
42347 C     changed to avoid recursive function calls (R.Engel, 09/98)
42348 C
42349 C***********************************************************************
42350       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42351       SAVE
42352
42353       INTEGER NA(NARG), INDEX(32)
42354       DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
42355
42356       DATA ZEROD/0.D0/
42357       DATA ONED/1.D0/
42358
42359       DBFINT    =  ZEROD
42360       PHO_DBFINT =  ZEROD
42361       IF(NARG .LT. 1  .OR.  NARG .GT. 5)  RETURN
42362
42363            LMAX      =  0
42364            ISTEP     =  1
42365            KNOTS     =  1
42366            INDEX(1)  =  1
42367            WEIGHT(1) =  ONED
42368            DO 100    N  =  1, NARG
42369               X     =  ARG(N)
42370               NDIM  =  NA(N)
42371               LOCA  =  LMAX
42372               LMIN  =  LMAX + 1
42373               LMAX  =  LMAX + NDIM
42374               IF(NDIM .GT. 2)  GOTO 10
42375               IF(NDIM .EQ. 1)  GOTO 100
42376               H  =  X - ENT(LMIN)
42377               IF(H .EQ. ZEROD)  GOTO 90
42378               ISHIFT  =  ISTEP
42379               IF(X-ENT(LMIN+1) .EQ. ZEROD)  GOTO 21
42380               ISHIFT  =  0
42381               ETA     =  H / (ENT(LMIN+1) - ENT(LMIN))
42382               GOTO 30
42383    10         LOCB  =  LMAX + 1
42384    11         LOCC  =  (LOCA+LOCB) / 2
42385               IF(X-ENT(LOCC))  12, 20, 13
42386    12         LOCB  =  LOCC
42387               GOTO 14
42388    13         LOCA  =  LOCC
42389    14         IF(LOCB-LOCA .GT. 1)  GOTO 11
42390               LOCA    =  MIN ( MAX (LOCA,LMIN), LMAX-1 )
42391               ISHIFT  =  (LOCA - LMIN) * ISTEP
42392               ETA     =  (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
42393               GOTO 30
42394    20         ISHIFT  =  (LOCC - LMIN) * ISTEP
42395    21         DO 22  K  =  1, KNOTS
42396                  INDEX(K)  =  INDEX(K) + ISHIFT
42397    22         CONTINUE
42398               GOTO 90
42399    30         DO 31  K  =  1, KNOTS
42400                  INDEX(K)         =  INDEX(K) + ISHIFT
42401                  INDEX(K+KNOTS)   =  INDEX(K) + ISTEP
42402                  WEIGHT(K+KNOTS)  =  WEIGHT(K) * ETA
42403                  WEIGHT(K)        =  WEIGHT(K) - WEIGHT(K+KNOTS)
42404    31         CONTINUE
42405               KNOTS  =  2*KNOTS
42406    90         ISTEP  =  ISTEP * NDIM
42407   100      CONTINUE
42408            DO 200    K  =  1, KNOTS
42409               I  =  INDEX(K)
42410               DBFINT =  DBFINT + WEIGHT(K) * TABLE(I)
42411   200      CONTINUE
42412
42413       PHO_DBFINT = DBFINT
42414
42415       END
42416
42417 *$ CREATE PHVAL.FOR
42418 *COPY PHVAL
42419 CDECK  ID>, PHVAL
42420       SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
42421 C**********************************************************************
42422 C
42423 C   dummy subroutine, remove to link PHOLIB
42424 C
42425 C**********************************************************************
42426       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42427       DIMENSION PD(-6:6)
42428       END