DPMJET/phojet1.12-35c.f

   1 C***********************************************************************
   2 C
   3 C
   4 C
   5 C                       PHOJET version 1.12
   6 C                       -------------------
   7 C
   8 C
   9 C    ($Revision$, $Date$)
  10 C
  11 C
  12 C    Authors: Ralph Engel
  13 C             (eng@lepton.bartol.udel.edu)
  14 C
  15 C             Johannes Ranft
  16 C             (johannes.ranft@cern.ch)
  17 C
  18 C             Stefan Roesler
  19 C             (sroesler@SLAC.Stanford.EDU)
  20 C
  21 C
  22 C    For the latest version and documentation check
  23 C       http://lepton.bartol.udel.edu/~eng/phojet.html
  24 C
  25 C
  26 C    Bug reports, questions, complaints are welcome
  27 C    (please send a mail to eng@lepton.bartol.udel).
  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 CDECK  ID>, PHO_INIT
 398 **sr temporarily changed
 399 C     SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
 400       SUBROUTINE PHO_INIT(LINP,IREJ)
 401 **
 402 C***********************************************************************
 403 C
 404 C     main subroutine to configure and manage PHOJET calculations
 405 C
 406 C     input:  LINP       input unit to read from
 407 C                        -1 to skip reading of input file
 408 C             LOUT       output unit to write to
 409 C
 410 C     output: IREJ       0  success
 411 C                        1  failure
 412 C
 413 C***********************************************************************
 414       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
 415       SAVE
 416
 417 C  input/output channels
 418       INTEGER LI,LO
 419       COMMON /POINOU/ LI,LO
 420 C  event debugging information
 421       INTEGER NMAXD
 422       PARAMETER (NMAXD=100)
 423       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
 424      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 425       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
 426      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 427 C  model switches and parameters
 428       CHARACTER*8 MDLNA
 429       INTEGER ISWMDL,IPAMDL
 430       DOUBLE PRECISION PARMDL
 431       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
 432 C  general process information
 433       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
 434       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
 435
 436 C  global event kinematics and particle IDs
 437       INTEGER IFPAP,IFPAB
 438       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
 439       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
 440 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
 441       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
 442       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
 443       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
 444      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
 445 C  integration precision for hard cross sections (obsolete)
 446       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 447       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 448 C  some hadron information, will be deleted in future versions
 449       INTEGER NFS
 450       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
 451       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
 452 C  obsolete cut-off information
 453       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
 454       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
 455 C  photon flux kinematics and cuts
 456       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
 457      &                 YMIN1,YMAX1,YMIN2,YMAX2,
 458      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 459      &                 THMIN1,THMAX1,THMIN2,THMAX2
 460       INTEGER          ITAG1,ITAG2
 461       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
 462      &                YMIN1,YMAX1,YMIN2,YMAX2,
 463      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 464      &                THMIN1,THMAX1,THMIN2,THMAX2,
 465      &                ITAG1,ITAG2
 466 C  cut probability distribution
 467       INTEGER IEETA1,IIMAX,KKMAX
 468       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
 469       INTEGER IEEMAX,IMAX,KMAX
 470       REAL PROB
 471       DOUBLE PRECISION EPTAB
 472       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
 473      &                IEEMAX,IMAX,KMAX
 474 C  event weights and generated cross section
 475       INTEGER IPOWGC,ISWCUT,IVWGHT
 476       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
 477       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
 478      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
 479 C  names of hard scattering processes
 480       INTEGER Max_pro_1
 481       PARAMETER ( Max_pro_1 = 16 )
 482       CHARACTER*18 PROC
 483       COMMON /POHPRO/ PROC(0:Max_pro_1)
 484 C  hard cross sections and MC selection weights
 485       INTEGER Max_pro_2
 486       PARAMETER ( Max_pro_2 = 16 )
 487       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
 488      &  MH_acc_1,MH_acc_2
 489       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
 490       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
 491      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
 492      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
 493      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
 494      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
 495
 496       INTEGER MSTU,MSTJ
 497       DOUBLE PRECISION PARU,PARJ
 498       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 499
 500       INTEGER KCHG
 501       DOUBLE PRECISION  PMAS,PARF,VCKM
 502       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
 503
 504       INTEGER MDCY,MDME,KFDP
 505       DOUBLE PRECISION  BRAT
 506       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
 507
 508       INTEGER PYCOMP
 509
 510       DIMENSION ITMP(0:11)
 511       CHARACTER*10 CNAME
 512       CHARACTER*70 NUMBER,FILENA
 513
 514  14   FORMAT(A10,A69)
 515  15   FORMAT(A12)
 516
 517 C  define input/output units
 518       IF(LINP.GE.0) THEN
 519         LI = LINP
 520       ELSE
 521         LI = 5
 522       ENDIF
 523 **sr temporarily changed
 524 C     LO = LOUT
 525       LO = 6
 526 **
 527
 528       IREJ = 0
 529
 530       WRITE(LO,*)
 531       WRITE(LO,*) ' ==================================================='
 532       WRITE(LO,*) '                                                    '
 533       WRITE(LO,*) '      ----      PHOJET version 1.12      ----      '
 534       WRITE(LO,*) '                                                    '
 535       WRITE(LO,*) ' ==================================================='
 536       WRITE(LO,*) '     Authors: Ralph Engel      (Bartol Res. Inst.)'
 537       WRITE(LO,*) '              Johannes Ranft   (Siegen Univ.)'
 538       WRITE(LO,*) '              Stefan Roesler   (SLAC)'
 539       WRITE(LO,*) ' ---------------------------------------------------'
 540       WRITE(LO,*) '   Manual, updates, and further information:'
 541       WRITE(LO,*) '    http://lepton.bartol.udel.edu/~eng/phojet.html'
 542       WRITE(LO,*) ' ---------------------------------------------------'
 543       WRITE(LO,*) '    please send suggestions / bug reports etc. to:'
 544       WRITE(LO,*) '             eng@lepton.bartol.udel.edu'
 545       WRITE(LO,*) ' ==================================================='
 546       WRITE(LO,*) '   $Date$'
 547       WRITE(LO,*) '   $Revision$'
 548
 549       WRITE(LO,*) '   (code version with interface to PYTHIA 6.x)'
 550
 551       WRITE(LO,*) '   (code version for usage in DPMJET 3.x)'
 552
 553       WRITE(LO,*) ' ==================================================='
 554       WRITE(LO,*)
 555
 556 C  standard initializations
 557       CALL PHO_DATINI
 558       CALL PHO_PARDAT
 559       DUM = PHO_PMASS(0,-1)
 560
 561 C  initialize standard PDFs
 562 C  proton
 563       CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
 564       CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
 565 C  neutron
 566       CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
 567       CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
 568 C  photon
 569       CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
 570 C  pomeron
 571       CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
 572 C  pions
 573       CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
 574       CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
 575       CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
 576 C  kaons
 577       CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
 578       CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
 579       CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
 580       CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
 581
 582 C  nothing to be done
 583       IF(LINP.LT.0) RETURN
 584
 585 C  main loop to read input cards
 586  1200 CONTINUE
 587         READ(LINP,14,END=1300) CNAME,NUMBER
 588         IF(CNAME.EQ.'ENDINPUT  ') THEN
 589           GOTO 1300
 590         ELSE IF(CNAME.EQ.'STOP      ') THEN
 591           WRITE(LO,*) 'STOP'
 592           STOP
 593         ELSE IF(CNAME.EQ.'COMMENT   ') THEN
 594           WRITE(LO,'(1X,A10,A69)') 'COMMENT   ',NUMBER
 595         ELSE IF(CNAME(1:1).EQ.'*') THEN
 596           WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
 597         ELSE IF(CNAME.EQ.'PTCUT     ') THEN
 598           READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
 599           WRITE(LO,*) 'PTCUT     ',PARMDL(36),PARMDL(37),
 600      &      PARMDL(38),PARMDL(39)
 601         ELSE IF(CNAME.EQ.'PROCESS   ') THEN
 602           READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
 603           WRITE(LO,*) 'PROCESS   ',(IPRON(KK,1),KK=1,8)
 604         ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
 605           READ(NUMBER,*) (ITMP(KK),KK=0,11)
 606           WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
 607           DO 112 KK=1,8
 608             IPRON(KK,ITMP(0)) = ITMP(KK)
 609  112      CONTINUE
 610         ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
 611           READ(NUMBER,*) IMPRO,IP,ION
 612           WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
 613           MH_pro_on(IMPRO,IP) = ION
 614         ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
 615           READ(NUMBER,*) IDPDG,PVIR
 616           IHFLS(1) = 1
 617           XPSUB = 1.D0
 618           CALL PHO_SETPAR(1,IDPDG,0,PVIR)
 619           WRITE(LO,*) 'PARTICLE1  ',IDPDG,PVIR
 620         ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
 621           READ(NUMBER,*) IDPDG,PVIR
 622           IHFLS(2) = 1
 623           XTSUB = 1.D0
 624           CALL PHO_SETPAR(2,IDPDG,0,PVIR)
 625           WRITE(LO,*) 'PARTICLE2  ',IDPDG,PVIR
 626         ELSE IF(CNAME.EQ.'REMNANT1  ') THEN
 627           READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
 628           IHFLS(1) = IVAL
 629           IHFLD(1,1) = IFL1
 630           IHFLD(1,2) = IFL2
 631           XPSUB = XSUB
 632           PVIR = 0.D0
 633           CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
 634           WRITE(LO,*) 'REMNANT1   ',IDPDG,IFL1,IFL2,IVAL,XSUB
 635         ELSE IF(CNAME.EQ.'REMNANT2  ') THEN
 636           READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
 637           IHFLS(2) = IVAL
 638           IHFLD(2,1) = IFL1
 639           IHFLD(2,2) = IFL2
 640           XTSUB = XSUB
 641           PVIR = 0.D0
 642           CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
 643           WRITE(LO,*) 'REMNANT2   ',IDPDG,IFL1,IFL2,IVAL,XSUB
 644         ELSE IF(CNAME.EQ.'PDF       ') THEN
 645           READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
 646           WRITE(LO,*) 'PDF        ',IDPDG,IPAR,ISET,IEXT
 647           CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
 648         ELSE IF(CNAME.EQ.'SETMODEL  ') THEN
 649           READ(NUMBER,*) I,IVAL
 650           WRITE(LO,*) 'SETMODEL   ',I,IVAL
 651           CALL PHO_SETMDL(I,IVAL,1)
 652         ELSE IF(CNAME.EQ.'SETPARAM  ') THEN
 653           READ(NUMBER,*) I,PARNEW
 654           WRITE(LO,*) 'SETPARAM   ',I,PARNEW
 655           PARMDL(I) = PARNEW
 656         ELSE IF(CNAME.EQ.'DEBUG     ') THEN
 657           READ(NUMBER,*) IDEBF,IDEBN,IDLEV
 658           WRITE(LO,*) 'DEBUG      ',IDEBF,IDEBN,IDLEV
 659           CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
 660         ELSE IF(CNAME.EQ.'TRACE     ') THEN
 661           READ(NUMBER,*) IDEBF,IDLEV
 662           WRITE(LO,*) 'TRACE      ',IDEBF,IDLEV
 663           IDEB(IDEBF) = IDLEV
 664         ELSE IF(CNAME.EQ.'SETICUT   ') THEN
 665           READ(NUMBER,*) I,ICUT
 666           WRITE(LO,*) 'SETICUT    ',I,ICUT
 667           ISWCUT(I) = ICUT
 668         ELSE IF(CNAME.EQ.'SETFCUT   ') THEN
 669           READ(NUMBER,*) I,PARNEW
 670           WRITE(LO,*) 'SETFCUT    ',I,PARNEW
 671           HSWCUT(I) = PARNEW
 672         ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
 673           READ(NUMBER,*) I,IVAL
 674           WRITE(LO,*) 'LUND-MSTU  ',I,IVAL
 675           MSTU(I) = IVAL
 676         ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
 677           READ(NUMBER,*) I,IVAL
 678           WRITE(LO,*) 'LUND-MSTJ  ',I,IVAL
 679           MSTJ(I) = IVAL
 680         ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
 681           READ(NUMBER,*) I,EE
 682           WRITE(LO,*) 'LUND-PARJ  ',I,EE
 683           PARJ(I) = REAL(EE)
 684         ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
 685           READ(NUMBER,*) I,EE
 686           WRITE(LO,*) 'LUND-PARU  ',I,EE
 687           PARU(I) = REAL(EE)
 688         ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
 689           READ(NUMBER,*) ID,ION
 690           WRITE(LO,*) 'LUND-DECAY ',ID,ION
 691
 692           KC=PYCOMP(ID)
 693
 694           MDCY(KC,1) = ION
 695         ELSE IF(CNAME.EQ.'PSOFTMIN  ') THEN
 696           READ(NUMBER,*) PSOMIN
 697           WRITE(LO,*) 'PSOFTMIN   ',PSOMIN
 698         ELSE IF(CNAME.EQ.'INTPREC   ') THEN
 699           READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 700           WRITE(LO,*) 'INTPREC    ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 701
 702 C  PDF test utility
 703         ELSE IF(CNAME.EQ.'PDFTEST   ') THEN
 704           READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
 705           PVIRT2 = ABS(PVIRT2)
 706           WRITE(LO,*) 'PDFTEST   ',IDPDG,' ',SCALE2,' ',PVIRT2
 707           CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
 708
 709 C  mass cut on gamma-gamma or gamma-hadron system
 710         ELSE IF(CNAME.EQ.'ECMS-CUT  ') THEN
 711           READ(NUMBER,*) ECMIN,ECMAX
 712           WRITE(LO,*) 'ECMS-CUT  ',ECMIN,ECMAX
 713
 714 C  beam lepton (anti-)tagging system
 715         ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
 716           READ(NUMBER,*) ITAG1,ITAG2
 717           WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
 718         ELSE IF(CNAME.EQ.'E-TAG1    ') THEN
 719           READ(NUMBER,*)
 720      &      EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
 721           WRITE(LO,*) 'E-TAG1    ',EEMIN1,YMIN1,YMAX1,
 722      &      Q2MIN1,Q2MAX1,THMIN1,THMAX1
 723         ELSE IF(CNAME.EQ.'E-TAG2    ') THEN
 724           READ(NUMBER,*)
 725      &      EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
 726           WRITE(LO,*) 'E-TAG2    ',EEMIN2,YMIN2,YMAX2,
 727      &      Q2MIN2,Q2MAX2,THMIN2,THMAX2
 728
 729 C  sampling of gamma-p events in ep (HERA)
 730         ELSE IF(    (CNAME.EQ.'WW-HERA   ')
 731      &          .OR.(CNAME.EQ.'GP-HERA   ')) THEN
 732           READ(NUMBER,*) EE1,EE2,NEV
 733           WRITE(LO,*) 'GP-HERA   ',EE1,EE2,NEV
 734           IF(YMAX2.LT.0.D0) THEN
 735             WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
 736           ELSE
 737             CALL PHO_GPHERA(NEV,EE1,EE2)
 738             KEVENT = 0
 739           ENDIF
 740
 741 C  sampling of gamma-gamma events in e+e- (LEP)
 742         ELSE IF(    (CNAME.EQ.'GG-EPEM   ')
 743      &          .OR.(CNAME.EQ.'WW-EPEM   ')) THEN
 744           READ(NUMBER,*) EE1,EE2,NEV
 745           WRITE(LO,*) 'GG-EPEM   ',EE1,EE2,NEV
 746           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 747             WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
 748           ELSE
 749             CALL PHO_GGEPEM(-1,EE1,EE2)
 750             CALL PHO_GGEPEM(NEV,EE1,EE2)
 751             CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
 752             KEVENT = 0
 753           ENDIF
 754
 755 C  sampling of gamma-gamma in heavy-ion collisions
 756         ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
 757           READ(NUMBER,*) EE,NA,NZ,NEV
 758           WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
 759           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 760             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 761           ELSE
 762             CALL PHO_GGHIOF(NEV,EE,NA,NZ)
 763             KEVENT = 0
 764           ENDIF
 765         ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
 766           READ(NUMBER,*) EE,NA,NZ,NEV
 767           WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
 768           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 769             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 770           ELSE
 771             CALL PHO_GGHIOG(NEV,EE,NA,NZ)
 772             KEVENT = 0
 773           ENDIF
 774
 775 C  sampling of gamma-hadron events in heavy ion collisions
 776         ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
 777           READ(NUMBER,*) EE,NA,NZ,NEV
 778           WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
 779           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 780             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 781           ELSE
 782             CALL PHO_GHHIOF(NEV,EE,NA,NZ)
 783             KEVENT = 0
 784           ENDIF
 785
 786 C  sampling of hadron-gamma events in hadron - heavy ion collisions
 787         ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
 788           READ(NUMBER,*) EP,EE,NA,NZ,NEV
 789           WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
 790           IF(YMAX2.LT.0.D0) THEN
 791             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 792           ELSE
 793             CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
 794             KEVENT = 0
 795           ENDIF
 796
 797 C  sampling of photoproduction events e+e-, backscattered laser
 798         ELSE IF(CNAME.EQ.'BLASER    ') THEN
 799           READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
 800           WRITE(LO,*) 'BLASER    ',EE1,EE2,
 801      &      Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
 802           CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
 803           KEVENT = 0
 804
 805 C  sampling of photoproduction events beamstrahlung
 806         ELSE IF(CNAME.EQ.'BEAMST    ') THEN
 807           READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
 808           WRITE(LO,*) 'BEAMST    ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
 809           IF(YMAX1.LT.0.D0) THEN
 810             WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
 811           ELSE
 812             CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
 813             KEVENT = 0
 814           ENDIF
 815
 816 C  fixed-energy events in LAB system of particle 2
 817         ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
 818           READ(NUMBER,*) PLAB,NEV
 819           WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
 820           CALL PHO_FIXLAB(PLAB,NEV)
 821           KEVENT = 0
 822
 823 C  fixed-energy events in CM system
 824         ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
 825           READ(NUMBER,*) ECM,NEV
 826           WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
 827           PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
 828           PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
 829           CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
 830           E1 = EE
 831           E2 = ECM-EE
 832           THETA = 0.D0
 833           PHI   = 0.D0
 834           CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
 835           KEVENT = 0
 836
 837 C  fixed-energy events for collider setup with crossing angle
 838         ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
 839           READ(NUMBER,*) E1,E2,THETA,PHI,NEV
 840           WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
 841           CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
 842           KEVENT = 0
 843
 844 C  unknown data card
 845         ELSE
 846           WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
 847         ENDIF
 848
 849       GOTO 1200
 850  1300 CONTINUE
 851       WRITE(LO,*) ' RETURN'
 852
 853       END
 854
 855 CDECK  ID>, PHO_SETMDL
 856       SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
 857 C**********************************************************************
 858 C
 859 C     set model switches
 860 C
 861 C     input:  INDX       model parameter number
 862 C                        (positive: ISWMDL, negative: IPAMDL)
 863 C             IVAL       new value
 864 C             IMODE      -1  print value of parameter INDX
 865 C                        1   set new value
 866 C                        -2  print current settings
 867 C
 868 C**********************************************************************
 869       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
 870       SAVE
 871
 872 C  input/output channels
 873       INTEGER LI,LO
 874       COMMON /POINOU/ LI,LO
 875 C  model switches and parameters
 876       CHARACTER*8 MDLNA
 877       INTEGER ISWMDL,IPAMDL
 878       DOUBLE PRECISION PARMDL
 879       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
 880
 881       IF(IMODE.EQ.-2) THEN
 882 C *** Commented by Chiara
 883 C        WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
 884 C     &                             '----------------------------'
 885         DO 100 I=1,48,3
 886           IF(ISWMDL(I).EQ.-9999) GOTO 200
 887           IF(ISWMDL(I+1).EQ.-9999) THEN
 888 C *** Commented by Chiara
 889 C            WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
 890             GOTO 200
 891           ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
 892 C            WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
 893 C     &        I+1,':',MDLNA(I+1),ISWMDL(I+1)
 894             GOTO 200
 895           ELSE
 896 C            WRITE(LO,'(3(5X,I3,A1,A,I6))')
 897 C     &        (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
 898           ENDIF
 899  100    CONTINUE
 900  200    CONTINUE
 901       ELSE IF(IMODE.EQ.-1) THEN
 902 C        WRITE(LO,'(1X,A,1X,A,I6)')
 903 C     &    'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
 904       ELSE IF(IMODE.EQ.1) THEN
 905         IF(INDX.GT.0) THEN
 906           IF(ISWMDL(INDX).NE.IVAL) THEN
 907             WRITE(LO,'(1X,A,I4,1X,A,2I6)')
 908      &        'PHO_SETMDL:ISWMDL(OLD/NEW):',
 909      &        INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
 910             ISWMDL(INDX) = IVAL
 911           ENDIF
 912         ELSE IF(INDX.LT.0) THEN
 913           IF(IPAMDL(-INDX).NE.IVAL) THEN
 914             WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
 915      &        -INDX,IPAMDL(-INDX),IVAL
 916             IPAMDL(-INDX) = IVAL
 917           ENDIF
 918         ENDIF
 919       ELSE
 920         WRITE(LO,'(/1X,A,I6)')
 921      &    'PHO_SETMDL:ERROR: unsupported mode',IMODE
 922       ENDIF
 923       END
 924
 925 CDECK  ID>, PHO_DATINI
 926       SUBROUTINE PHO_DATINI
 927 C*********************************************************************
 928 C
 929 C     initialization of variables and switches
 930 C
 931 C*********************************************************************
 932       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
 933       SAVE
 934
 935 C  input/output channels
 936       INTEGER LI,LO
 937       COMMON /POINOU/ LI,LO
 938 C  some constants
 939       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
 940       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
 941      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
 942 C  event debugging information
 943       INTEGER NMAXD
 944       PARAMETER (NMAXD=100)
 945       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
 946      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 947       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
 948      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 949 C  event weights and generated cross section
 950       INTEGER IPOWGC,ISWCUT,IVWGHT
 951       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
 952       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
 953      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
 954 C  scale parameters for parton model calculations
 955       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
 956       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
 957       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
 958      &                NQQAL,NQQALI,NQQALF,NQQPD
 959 C  integration precision for hard cross sections (obsolete)
 960       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 961       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 962 C  hard scattering parameters used for most recent hard interaction
 963       INTEGER NFbeta,NF
 964       DOUBLE PRECISION ALQCD2,BQCD
 965       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
 966 C  cut probability distribution
 967       INTEGER IEETA1,IIMAX,KKMAX
 968       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
 969       INTEGER IEEMAX,IMAX,KMAX
 970       REAL PROB
 971       DOUBLE PRECISION EPTAB
 972       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
 973      &                IEEMAX,IMAX,KMAX
 974 C  gamma-lepton or gamma-hadron vertex information
 975       INTEGER IGHEL,IDPSRC,IDBSRC
 976       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
 977      &                 RADSRC,AMSRC,GAMSRC
 978       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
 979      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
 980      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
 981 C  photon flux kinematics and cuts
 982       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
 983      &                 YMIN1,YMAX1,YMIN2,YMAX2,
 984      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 985      &                 THMIN1,THMAX1,THMIN2,THMAX2
 986       INTEGER          ITAG1,ITAG2
 987       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
 988      &                YMIN1,YMAX1,YMIN2,YMAX2,
 989      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 990      &                THMIN1,THMAX1,THMIN2,THMAX2,
 991      &                ITAG1,ITAG2
 992 C  obsolete cut-off information
 993       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
 994       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
 995 C  global event kinematics and particle IDs
 996       INTEGER IFPAP,IFPAB
 997       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
 998       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
 999 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
1000       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
1001       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
1002       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
1003      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
1004 C  some hadron information, will be deleted in future versions
1005       INTEGER NFS
1006       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
1007       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
1008 C  model switches and parameters
1009       CHARACTER*8 MDLNA
1010       INTEGER ISWMDL,IPAMDL
1011       DOUBLE PRECISION PARMDL
1012       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
1013 C  general process information
1014       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
1015       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
1016 C  parameters of the "simple" Vector Dominance Model
1017       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
1018       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
1019 C  parameters for DGLAP backward evolution in ISR
1020       INTEGER NFSISR
1021       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
1022       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
1023 C  particles created by initial state evolution
1024       INTEGER MXISR1,MXISR2
1025       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
1026       INTEGER IFLISR,IPOISR,IMXISR
1027       DOUBLE PRECISION PHISR
1028       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
1029      &                IPOISR(2,2,MXISR2),IMXISR(2)
1030 C  names of hard scattering processes
1031       INTEGER Max_pro_1
1032       PARAMETER ( Max_pro_1 = 16 )
1033       CHARACTER*18 PROC
1034       COMMON /POHPRO/ PROC(0:Max_pro_1)
1035 C  hard cross sections and MC selection weights
1036       INTEGER Max_pro_2
1037       PARAMETER ( Max_pro_2 = 16 )
1038       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
1039      &  MH_acc_1,MH_acc_2
1040       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
1041       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
1042      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
1043      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
1044      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
1045      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
1046 C  interpolation tables for hard cross section and MC selection weights
1047       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
1048       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
1049       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
1050       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
1051      &  HQ2a_tab,HQ2b_tab,HEcm_tab
1052       COMMON /POHTAB/
1053      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1054      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1055      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1056      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1057      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
1058      &  HEcm_tab(1:Max_tab_E,0:4),
1059      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
1060
1061 C  initialize /POCONS/
1062       PI   = ATAN(1.D0)*4.D0
1063       PI2  = 2.D0*PI
1064       PI4  = 2.D0*PI2
1065 C  GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
1066       GEV2MB = 0.389365D0
1067 C  precalculate quark charges
1068       do i=1,6
1069         Q_ch(i) = dble(2-3*mod(i,2))/3.D0
1070         Q_ch(-i) = -Q_ch(i)
1071
1072         Q_ch2(i) = Q_ch(i)**2
1073         Q_ch2(-i) = Q_ch2(i)
1074
1075         Q_ch4(i) = Q_ch2(i)**2
1076         Q_ch4(-i) = Q_ch4(i)
1077       enddo
1078       Q_ch(0)  = 0.D0
1079       Q_ch2(0) = 0.D0
1080       Q_ch4(0) = 0.D0
1081
1082 C  initialize /GLOCMS/
1083       ECM    = 50.D0
1084       PMASS(1) = 0.D0
1085       PVIRT(1) = 0.D0
1086       PMASS(2) = 0.D0
1087       PVIRT(2) = 0.D0
1088       IFPAP(1) = 22
1089       IFPAP(2) = 22
1090 C  initialize /HADVAL/
1091       IHFLD(1,1) = 0
1092       IHFLD(1,2) = 0
1093       IHFLD(2,1) = 0
1094       IHFLD(2,2) = 0
1095       IHFLS(1) = 1
1096       IHFLS(2) = 1
1097 C  initialize /MODELS/
1098       ISWMDL(1)  = 3
1099       MDLNA(1)  = 'AMPL MOD'
1100       ISWMDL(2)  = 1
1101       MDLNA(2)  = 'MIN-BIAS'
1102       ISWMDL(3)  = 1
1103       MDLNA(3)  = 'PTS DISH'
1104       ISWMDL(4)  = 1
1105       MDLNA(4)  = 'PTS DISP'
1106       ISWMDL(5)  = 2
1107       MDLNA(5)  = 'PTS ASSI'
1108       ISWMDL(6)  = 3
1109       MDLNA(6)  = 'HADRONIZ'
1110       ISWMDL(7)  = 2
1111       MDLNA(7)  = 'MASS COR'
1112       ISWMDL(8)  = 3
1113       MDLNA(8)  = 'PAR SHOW'
1114       ISWMDL(9)  = 0
1115       MDLNA(9)  = 'GLU SPLI'
1116       ISWMDL(10) = 2
1117       MDLNA(10) = 'VIRT PHO'
1118       ISWMDL(11) = 0
1119       MDLNA(11) = 'LARGE NC'
1120       ISWMDL(12) = 0
1121       MDLNA(12) = 'LIPA POM'
1122       ISWMDL(13) = 1
1123       MDLNA(13) = 'QELAS VM'
1124       ISWMDL(14) = 2
1125       MDLNA(14) = 'ENHA GRA'
1126       ISWMDL(15) = 4
1127       MDLNA(15) = 'MULT SCA'
1128       ISWMDL(16) = 4
1129       MDLNA(16) = 'MULT DIF'
1130       ISWMDL(17) = 4
1131       MDLNA(17) = 'MULT CDF'
1132       ISWMDL(18) = 0
1133       MDLNA(18) = 'BALAN PT'
1134       ISWMDL(19) = 1
1135       MDLNA(19) = 'POMV FLA'
1136       ISWMDL(20) = 0
1137       MDLNA(20) = 'SEA  FLA'
1138       ISWMDL(21) = 2
1139       MDLNA(21) = 'SPIN DEC'
1140       ISWMDL(22) = 1
1141       MDLNA(22) = 'DIF.MASS'
1142       ISWMDL(23) = 1
1143       MDLNA(23) = 'DIFF RES'
1144       ISWMDL(24) = 0
1145       MDLNA(24) = 'PTS HPOM'
1146       ISWMDL(25) = 0
1147       MDLNA(25) = 'POM CORR'
1148       ISWMDL(26) = 1
1149       MDLNA(26) = 'OVERLAP '
1150       ISWMDL(27) = 0
1151       MDLNA(27) = 'MUL R/AN'
1152       ISWMDL(28) = 1
1153       MDLNA(28) = 'SUR PROB'
1154       ISWMDL(29) = 1
1155       MDLNA(29) = 'PRIMO KT'
1156       ISWMDL(30) = 0
1157       MDLNA(30) = 'DIFF. CS'
1158       ISWMDL(31) = -9999
1159 C  mass-independent sea flavour ratios (for low-mass strings)
1160       PARMDL(1)  = 0.425D0
1161       PARMDL(2)  = 0.425D0
1162       PARMDL(3)  = 0.15D0
1163       PARMDL(4)  = 0.D0
1164       PARMDL(5)  = 0.D0
1165       PARMDL(6)  = 0.D0
1166 C  suppression by energy momentum conservation
1167       PARMDL(8)  = 9.D0
1168       PARMDL(9)  = 7.D0
1169 C  VDM factors
1170       PARMDL(10) = 0.866D0
1171       PARMDL(11) = 0.288D0
1172       PARMDL(12) = 0.288D0
1173       PARMDL(13) = 0.288D0
1174       PARMDL(14) = 0.866D0
1175       PARMDL(15) = 0.288D0
1176       PARMDL(16) = 0.288D0
1177       PARMDL(17) = 0.288D0
1178       PARMDL(18) = 0.D0
1179 C  lower energy limit for initialization
1180       PARMDL(19) = 5.D0
1181 C  soft pt for hard scattering remnants
1182       PARMDL(20) = 5.D0
1183 C  low energy beta of soft pt distribution 1
1184       PARMDL(21) = 4.5D0
1185 C  high energy beta of soft pt distribution 1
1186       PARMDL(22) = 3.0D0
1187 C  low energy beta of soft pt distribution 0
1188       PARMDL(23) = 2.5D0
1189 C  high energy beta of soft pt distribution 0
1190       PARMDL(24) = 0.4D0
1191 C  effective quark mass in photon wave function
1192       PARMDL(25) = 0.2D0
1193 C  normalization of unevolved Pomeron PDFs
1194       PARMDL(26) = 0.3D0
1195 C  effective VDM parameters for Q**2 dependence of cross section
1196       PARMDL(27) = 0.65D0
1197       PARMDL(28) = 0.08D0
1198       PARMDL(29) = 0.05D0
1199       PARMDL(30) = 0.22D0
1200       PARMDL(31) = 0.589824D0
1201       PARMDL(32) = 0.609961D0
1202       PARMDL(33) = 1.038361D0
1203       PARMDL(34) = 1.96D0
1204 C  Q**2 suppression of multiple interactions
1205       PARMDL(35) = 0.59D0
1206 C  pt cutoff defaults
1207       PARMDL(36) = 2.5D0
1208       PARMDL(37) = 2.5D0
1209       PARMDL(38) = 2.5D0
1210       PARMDL(39) = 2.5D0
1211 C  enhancement factor for diffractive cross sections
1212       PARMDL(40) = 1.D0
1213       PARMDL(41) = 1.D0
1214       PARMDL(42) = 1.D0
1215 C  mass in soft pt distribution
1216       PARMDL(43) = 0.D0
1217 C  maximum of x allowed for leading particle
1218       PARMDL(44) = 0.9D0
1219 C  max. mass sampled in diffraction
1220       PARMDL(45) = sqrt(0.4D0)
1221 C  mass threshold in diffraction (2pi mass)
1222       PARMDL(46) = 0.3D0
1223 C  regularization of slope parameter in diffraction
1224       PARMDL(47) = 4.D0
1225 C  renormalized intercept for enhanced graphs
1226       PARMDL(48) = 1.08D0
1227 C  coherence constraint for diff. cross sections
1228       PARMDL(49) = sqrt(0.05D0)
1229 C  exponents of x distributions
1230 C  baryon
1231       PARMDL(50) = 1.5D0
1232       PARMDL(51) = -0.5D0
1233       PARMDL(52) = -0.99D0
1234       PARMDL(53) = -0.99D0
1235 C  meson (non-strangeness part)
1236       PARMDL(54) = -0.5D0
1237       PARMDL(55) = -0.5D0
1238       PARMDL(56) = -0.99D0
1239       PARMDL(57) = -0.99D0
1240 C  meson (strangeness part)
1241       PARMDL(58) = -0.2D0
1242       PARMDL(59) = -0.2D0
1243       PARMDL(60) = -0.99D0
1244       PARMDL(61) = -0.99D0
1245 C  particle remnant (no valence quarks)
1246       PARMDL(62) = -0.5D0
1247       PARMDL(63) = -0.5D0
1248       PARMDL(64) = -0.99D0
1249       PARMDL(65) = -0.99D0
1250 C  ratio beetween triple-pomeron/reggeon couplings grrp/gppp
1251       PARMDL(66) = 10.D0
1252 C  ratio beetween triple-pomeron/reggeon couplings gppr/gppp
1253       PARMDL(67) = 10.D0
1254 C  min. abs(t) in diffraction
1255       PARMDL(68) = 0.D0
1256 C  max. abs(t) in diffraction
1257       PARMDL(69) = 10.D0
1258 C  min. mass for elastic pomerons in central diffraction
1259       PARMDL(70) = 2.D0
1260 C  min. mass of diffractive blob in central diffraction
1261       PARMDL(71) = 2.D0
1262 C  min. Feynman x cut in central diffraction
1263       PARMDL(72) = 0.D0
1264 C  direct pomeron coupling
1265       PARMDL(74) = 0.D0
1266 C  relative deviation allowed for energy-momentum conservation
1267 C  energy-momentum relative deviation
1268       PARMDL(75) = 0.01D0
1269 C  transverse momentum deviation
1270       PARMDL(76) = 0.01D0
1271 C  couplings for unitarization in diffraction
1272 C  non-unitarized pomeron coupling (sqrt(mb))
1273       PARMDL(77)  = 3.D0
1274 C  rescaling factor for pomeron PDF
1275       PARMDL(78)  = 3.D0
1276 C  coupling probabilities
1277       PARMDL(79)  = 1.D0
1278       PARMDL(80)  = 0.D0
1279 C  scales to calculate alpha-s of matrix element
1280       PARMDL(81) = 1.D0
1281       PARMDL(82) = 1.D0
1282       PARMDL(83) = 1.D0
1283 C  scales to calculate alpha-s of initial state radiation
1284       PARMDL(84) = 1.D0
1285       PARMDL(85) = 1.D0
1286       PARMDL(86) = 1.D0
1287 C  scales to calculate alpha-s of final state radiation
1288       PARMDL(87) = 1.D0
1289       PARMDL(88) = 1.D0
1290       PARMDL(89) = 1.D0
1291 C  scales to calculate PDFs
1292       PARMDL(90) = 1.D0
1293       PARMDL(91) = 1.D0
1294       PARMDL(92) = 1.D0
1295 C  scale for ISR starting virtuality
1296       PARMDL(93) = 1.D0
1297 C  min. virtuality to generate time-like showers in ISR
1298       PARMDL(94) = 2.D0
1299 C  factor to scale the max. allowed time-like parton shower virtuality
1300       PARMDL(95) = 4.D0
1301 C  max. transverse momentum for primordial kt
1302       PARMDL(100) = 2.D0
1303 C  weight factors for pt-distribution
1304       PARMDL(101) = 2.D0
1305       PARMDL(102) = 2.D0
1306       PARMDL(103) = 4.D0
1307       PARMDL(104) = 2.D0
1308       PARMDL(105) = 6.D0
1309       PARMDL(106) = 4.D0
1310 C
1311 *     PARMDL(110-125)  reserved for hard scattering
1312 C  currently chosen scales for hard scattering
1313       DO 10 I=1,16
1314         PARMDL(109+I) = 0.D0
1315  10   CONTINUE
1316 C  virtuality cutoff in initial state evolution
1317       PARMDL(126) = PARMDL(36)**2
1318       PARMDL(127) = PARMDL(37)**2
1319       PARMDL(128) = PARMDL(38)**2
1320       PARMDL(129) = PARMDL(39)**2
1321 C  virtuality cutoff for direct contribution to photon PDF
1322       PARMDL(130) = 1.D30
1323       PARMDL(131) = 1.D30
1324       PARMDL(132) = 1.D30
1325       PARMDL(133) = 1.D30
1326 C  fraction of events without popcorn
1327       PARMDL(134) = -1.D0
1328 C  fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
1329       PARMDL(135) = 0.5D0
1330 C  soft color re-connection (fraction)
1331 C  g g final state
1332       PARMDL(140) = 1.D0/64.D0
1333 C  g q final state
1334       PARMDL(141) = 1.D0/24.D0
1335 C  q q final state
1336       PARMDL(142) = 1.D0/9.D0
1337 C  effective scale in Drees-Godbole like suppresion in photon PDF
1338       PARMDL(144) = 0.766D0**2
1339 C  QCD scales (if PDF scales are not used, 4 active flavours)
1340       PARMDL(145) = 0.2D0**2
1341       PARMDL(146) = 0.2D0**2
1342       PARMDL(147) = 0.2D0**2
1343 C  threshold scales for variable flavour calculation (GeV**2)
1344       PARMDL(148) = 1.5D0**2
1345       PARMDL(149) = 4.5D0**2
1346       PARMDL(150) = 175.D0**2
1347 C  constituent quark masses
1348       PARMDL(151) = 0.3D0
1349       PARMDL(152) = 0.3D0
1350       PARMDL(153) = 0.5D0
1351       PARMDL(154) = 1.6D0
1352       PARMDL(155) = 5.D0
1353       PARMDL(156) = 174.D0
1354 C  min. masses of valence quark
1355       PARMDL(157) = 0.3D0
1356 C  min. masses of valence diquark
1357       PARMDL(158) = 0.8D0
1358 C  min. mass of sea quark
1359       PARMDL(159) = 0.D0
1360 C  suppression of strange quarks as photon valences
1361       PARMDL(160) = 0.2D0
1362 C  min. masses for strings (used in PHO_SOFTXX)
1363       PARMDL(161) = 1.D0
1364       PARMDL(162) = 1.D0
1365       PARMDL(163) = 1.D0
1366       PARMDL(164) = 1.D0
1367 C  min. momentum fraction for soft processes
1368       PARMDL(165) = 0.3D0
1369 C  min. phase space for x-sampling
1370       PARMDL(166) = 0.135D0
1371 C  Ross-Stodolsky exponent
1372       PARMDL(170) = 4.2D0
1373 C  cutoff on photon-pomeron invariant mass in hadron-hadron collisions
1374       PARMDL(175) = 2.D0
1375
1376 **sr
1377 *  extra factor multiplying difference between Goulianos and PHOJET-
1378 *  diff. cross sections
1379       PARMDL(200) = 0.6D0
1380 **
1381
1382 C  complex amplitudes, eikonal functions
1383       IPAMDL(1)  = 0
1384 C  allow for Reggeon cuts
1385       IPAMDL(2)  = 1
1386 C  decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
1387       IPAMDL(3)  = 0
1388 C  polarization of photon resonances (0 none, 1 trans, 2 long)
1389       IPAMDL(4)  = 1
1390 C  pt of valence partons
1391       IPAMDL(5)  = 1
1392 C  pt of hard scattering remnant
1393       IPAMDL(6)  = 2
1394 C  running cutoff for hard scattering
1395       IPAMDL(7)  = 1
1396 C  intercept used for the calculation of enhanced graphs
1397       IPAMDL(8)  = 1
1398 C  effective slope of hard scattering amplitde
1399       IPAMDL(9)  = 1
1400 C  mass dependence of slope parameters
1401       IPAMDL(10) = 0
1402 C  lepton-photon vertex 1
1403       IPAMDL(11) = 0
1404 C  lepton-photon vertex 2
1405       IPAMDL(12) = 0
1406 C  call by DPMJET
1407       IPAMDL(13) = 0
1408 C  method to sample x distributions
1409       IPAMDL(14) = 3
1410 C  energy-momentum check
1411       IPAMDL(15) = 1
1412 C  phase space correction for DPMJET interface
1413       IPAMDL(16) = 1
1414 C  fragment strings from projectile/target/central diff. separately
1415       IPAMDL(17) = 1
1416 C  method to construct strings for hard interactions
1417       IPAMDL(18) = 1
1418 C  method to construct strings for soft sea (pomeron cuts)
1419       IPAMDL(19) = 0
1420 C  method to construct strings in pomeron interactions
1421       IPAMDL(20) = 0
1422 C  soft color re-connection
1423       IPAMDL(21) = 0
1424 C  resummation of triple- and loop-Pomeron
1425       IPAMDL(24) = 1
1426 C  resummation of X iterated triple-Pomeron
1427       IPAMDL(25) = 1
1428 C  dimension of interpolation table for weights in hard scattering
1429       IPAMDL(30) = Max_tab_E
1430 C  dimension of interpolation table for pomeron cut distribution
1431       IPAMDL(31) = IEETA1
1432 C  number of cut soft pomerons (restriction by field dimension)
1433       IPAMDL(32) = IIMAX
1434 C  number of cut hard pomerons (restriction by field dimension)
1435       IPAMDL(33) = KKMAX
1436 C  tau pair production in direct photon-photon collisions
1437       IPAMDL(64) = 0
1438 C  currently chosen scales for hard scattering
1439 C  ATTENTION:   IPAMDL(65-80)  reserved for hard scattering!
1440       DO 15 I=1,16
1441         IPAMDL(64+I) = -99999
1442  15   CONTINUE
1443 C  scales to calculate alpha-s of matrix element
1444       IPAMDL(81) = 1
1445       IPAMDL(82) = 1
1446       IPAMDL(83) = 1
1447 C  scales to calculate alpha-s of initial state radiation
1448       IPAMDL(84) = 1
1449       IPAMDL(85) = 1
1450       IPAMDL(86) = 1
1451 C  scales to calculate alpha-s of final state radiation
1452       IPAMDL(87) = 1
1453       IPAMDL(88) = 1
1454       IPAMDL(89) = 1
1455 C  scales to calculate PDFs
1456       IPAMDL(90) = 1
1457       IPAMDL(91) = 1
1458       IPAMDL(92) = 1
1459 C  where to get the parameter sets from
1460       IPAMDL(99) = 1
1461 C  program PHO_ABORT for fatal errors (simulation of division by zero)
1462       IPAMDL(100) = 0
1463 C  initial state parton showers for all / hardest interaction(s)
1464       IPAMDL(101) = 1
1465 C  final state parton showers for all / hardest interaction(s)
1466       IPAMDL(102) = 1
1467 C  initial virtuality for ISR generation
1468       IPAMDL(109) = 1
1469 C  qqbar-gamma coupling in initial state showers
1470       IPAMDL(110) = 1
1471 C  generation of time-like showers during ISR
1472       IPAMDL(111) = 1
1473 C  reweighting of multiple soft contributions for virtual photons
1474       IPAMDL(114) = 1
1475 C  reweighting / use photon virtuality in photon PDF calculations
1476       IPAMDL(115) = 0
1477 C  use full QPM model incl. interference terms (direct part in gam-gam)
1478       IPAMDL(116) = 0
1479 C  matching sigma_tot to F2 as given by parton density at high Q2
1480       IPAMDL(117) = 1
1481 C  use virtuality of target in F2 calculations (two-gamma only)
1482       IPAMDL(118) = 1
1483 C  calculation of alpha_em
1484       IPAMDL(120) = 1
1485 C  strict pt cutoff for gamma-gamma events
1486       IPAMDL(121) = 0
1487 C  photon virtuality sampled in photon flux approximations
1488       IPAMDL(174) = 1
1489 C  photon-pomeron: 0,1,2: both,left,right photon emission
1490       IPAMDL(175) = 0
1491 C  keep full history information in PHOJET-JETSET interface
1492       IPAMDL(178) = 1
1493 C  max. number of conservation law violations allowed in one run
1494       IPAMDL(179) = 20
1495 C  selection of soft X values
1496 C  max. iteration number in PHO_SELSXS
1497       IPAMDL(180) = 50
1498 C  max. iteration number in PHO_SELSXR
1499       IPAMDL(181) = 200
1500 C  max. iteration number in PHO_SELSX2
1501       IPAMDL(182) = 100
1502 C  max. iteration number in PHO_SELSXI
1503       IPAMDL(183) = 50
1504
1505 C  initialize /PROBAB/
1506       IEEMAX = IEETA1
1507       IMAX   = IIMAX
1508       KMAX   = KKMAX
1509
1510       DO 20 I=1,30
1511         PARMDL(300+I) = -100000.D0
1512  20   CONTINUE
1513 C  initialize /POHDRN/
1514       QMASS(1) =  PARMDL(151)
1515       QMASS(2) =  PARMDL(152)
1516       QMASS(3) =  PARMDL(153)
1517       QMASS(4) =  PARMDL(154)
1518       QMASS(5) =  PARMDL(155)
1519       QMASS(6) =  PARMDL(156)
1520       BET      = 8.D0
1521       PCOUDI   = 0.D0
1522       VALPRG(1) = 1.D0
1523       VALPRG(2) = 1.D0
1524 C  number of light flavours (quarks treated as massless)
1525       NFS      = 4
1526 C  initialize /POCUT1/
1527       PTCUT(1) = PARMDL(36)
1528       PTCUT(2) = PARMDL(37)
1529       PTCUT(3) = PARMDL(38)
1530       PTCUT(4) = PARMDL(39)
1531       PSOMIN = 0.D0
1532       XSOMIN = 0.D0
1533 C  initialize /POHAPA/
1534       NFbeta  = 4
1535       NF      = 4
1536       BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
1537       BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
1538       BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
1539       BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
1540 C  initialize /POGAUP/
1541       NGAUP1 = 12
1542       NGAUP2 = 12
1543       NGAUET = 16
1544       NGAUIN = 12
1545       NGAUSO = 96
1546 C  initialize //
1547       DO 30 I=1,100
1548         IDEB(I) = 0
1549  30   CONTINUE
1550 C  initialize /PROCES/
1551       DO 35 I=1,11
1552         IPRON(I,1) = 1
1553  35   CONTINUE
1554
1555 C  DPMJET default: no elastic scattering
1556       IPRON(2,1) = 0
1557
1558       DO 36 K=2,4
1559         DO 37 I=2,11
1560           IPRON(I,K) = 0
1561  37     CONTINUE
1562         IPRON(1,K) = 1
1563         IPRON(8,K) = 1
1564  36   CONTINUE
1565 C  initialize /POSVDM/
1566       TWOPIM = 0.28D0
1567       RMIN(1) = 0.285D0
1568       RMIN(2) = 0.45D0
1569       RMIN(3) = 1.D0
1570       RMIN(4) = TWOPIM
1571       VMAS(1) = 0.770D0
1572       VMAS(2) = 0.787D0
1573       VMAS(3) = 1.02D0
1574       VMAS(4) = TWOPIM
1575       GAMM(1) = 0.155D0
1576       GAMM(2) = 0.01D0
1577       GAMM(3) = 0.0045D0
1578       GAMM(4) = 1.D0
1579       RMAX(1) = VMAS(1)+TWOPIM
1580       RMAX(2) = VMAS(2)+TWOPIM
1581       RMAX(3) = VMAS(3)+TWOPIM
1582       RMAX(4) = VMAS(1)+TWOPIM
1583       VMSL(1) = 11.D0
1584       VMSL(2) = 10.D0
1585       VMSL(3) = 6.D0
1586       VMSL(4) = 4.D0
1587       VMFA(1) = 0.0033D0
1588       VMFA(2) = 0.00036D0
1589       VMFA(3) = 0.0002D0
1590       VMFA(4) = 0.0002D0
1591 C  initialize /PODGL1/
1592       Q2MISR(1) = PARMDL(36)**2
1593       Q2MISR(2) = PARMDL(36)**2
1594       PMISR(1) = 1.D0
1595       PMISR(2) = 1.D0
1596       ZMISR(1) = 0.001D0
1597       ZMISR(2) = 0.001D0
1598       AL2ISR(1) = 0.046D0
1599       AL2ISR(2) = 0.046D0
1600       NFSISR  = 4
1601 C  initialize /POPISR/
1602       DO 40 I=1,50
1603         IPOISR(1,2,I) = 0
1604         IPOISR(2,2,I) = 0
1605  40   CONTINUE
1606 C  initialize /POHPRO/
1607       PROC(0) = 'sum over processes'
1608       PROC(1) = 'G  +G  --> G  +G  '
1609       PROC(2) = 'Q  +QB --> G  +G  '
1610       PROC(3) = 'G  +Q  --> G  +Q  '
1611       PROC(4) = 'G  +G  --> Q  +QB '
1612       PROC(5) = 'Q  +QB --> Q  +QB '
1613       PROC(6) = 'Q  +QB --> QP +QBP'
1614       PROC(7) = 'Q  +Q  --> Q  +Q  '
1615       PROC(8) = 'Q  +QP --> Q  +QP '
1616       PROC(9) = 'resolved processes'
1617       PROC(10) = 'gam+Q  --> G  +Q  '
1618       PROC(11) = 'gam+G  --> Q  +QB '
1619       PROC(12) = 'Q  +gam--> G  +Q  '
1620       PROC(13) = 'G  +gam--> Q  +QB '
1621       PROC(14) = 'gam+gam--> Q  +QB '
1622       PROC(15) = 'direct processes  '
1623       PROC(16) = 'gam+gam--> l+ +l- '
1624
1625 C  initialize /POHRCS/
1626       do M=1,Max_pro_2
1627         HWgx(M) = 0.D0
1628         HSig(M) = 0.D0
1629         Hdpt(M) = 0.D0
1630       enddo
1631       DO I=0,4
1632         DO M=-1,Max_pro_2
1633 C  switch all hard subprocesses on
1634           MH_pro_on(M,I) = 1
1635 C  reset all counters
1636           MH_tried(M,I) = 0
1637           MH_acc_1(M,I) = 0
1638           MH_acc_2(M,I) = 0
1639         ENDDO
1640         MH_pro_on(16,I) = 0
1641       ENDDO
1642
1643 C  initialize /POHTAB/
1644       do I=0,4
1645         IH_Ecm_up(I) = 0
1646         IH_Q2a_up(I) = 0
1647         IH_Q2b_up(I) = 0
1648         HEcm_tab(1,I) = 0.D0
1649       enddo
1650       HEcm_last = 0.D0
1651       IHa_last = 0.D0
1652       IHb_last = 0.D0
1653
1654 C  initialize /POFSRC/
1655       IGHEL(1) = -1
1656       IGHEL(2) = -1
1657 C  initialize /LEPCUT/
1658       ECMIN = 5.D0
1659       ECMAX = 1.D+30
1660       EEMIN1 = 1.D0
1661       EEMIN2 = 1.D0
1662       YMAX1 = -1.D0
1663       YMAX2 = -1.D0
1664       THMIN1 = 0.D0
1665       THMAX1 = PI
1666       THMIN2 = 0.D0
1667       THMAX2 = PI
1668       ITAG1 = 1
1669       ITAG2 = 1
1670 C  initialize /POWGHT/
1671       DO 70 I=1,20
1672         HSWCUT(I) = 0.D0
1673         ISWCUT(I) = 0
1674  70   CONTINUE
1675       EVWGHT(1) = 1.D0
1676       IVWGHT(1) = 0
1677       SIGGEN(1) = 0.D0
1678       SIGGEN(2) = 0.D0
1679       SIGGEN(3) = 0.D0
1680       SIGGEN(4) = 0.D0
1681
1682       END
1683
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 CDECK  ID>, PHO_PRESEL
2482       SUBROUTINE PHO_PRESEL(MODE,IREJ)
2483 C**********************************************************************
2484 C
2485 C     user specific function to pre-select events during generation
2486 C
2487 C     input:   MODE  5  electron and photon kinematics
2488 C                   10  process and number of cut Pomerons
2489 C                   15  partons without construction of strings
2490 C                   20  partons assigned to strings
2491 C                   25  after fragmentation, complete final state
2492 C
2493 C     output:  IREJ  0  event accepted
2494 C                   50  event rejected
2495 C
2496 C**********************************************************************
2497       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2498       SAVE
2499
2500 C  input/output channels
2501       INTEGER LI,LO
2502       COMMON /POINOU/ LI,LO
2503 C  event debugging information
2504       INTEGER NMAXD
2505       PARAMETER (NMAXD=100)
2506       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2507      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2508       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2509      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2510
2511 C  standard particle data interface
2512       INTEGER NMXHEP
2513
2514       PARAMETER (NMXHEP=4000)
2515
2516       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
2517       DOUBLE PRECISION PHEP,VHEP
2518       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2519      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2520      &                VHEP(4,NMXHEP)
2521 C  extension to standard particle data interface (PHOJET specific)
2522       INTEGER IMPART,IPHIST,ICOLOR
2523       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
2524
2525 C  global event kinematics and particle IDs
2526       INTEGER IFPAP,IFPAB
2527       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2528       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2529 C  gamma-lepton or gamma-hadron vertex information
2530       INTEGER IGHEL,IDPSRC,IDBSRC
2531       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2532      &                 RADSRC,AMSRC,GAMSRC
2533       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2534      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2535      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2536 C  hard scattering data
2537       INTEGER MSCAHD
2538       PARAMETER ( MSCAHD = 50 )
2539       INTEGER LSCAHD,LSC1HD,LSIDX,
2540      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
2541       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
2542       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
2543      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
2544      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
2545      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
2546      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
2547      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
2548      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
2549 C  event weights and generated cross section
2550       INTEGER IPOWGC,ISWCUT,IVWGHT
2551       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2552       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2553      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2554
2555       IREJ = 0
2556
2557 *     XBJ = GQ2(2)/(GGECM**2+GQ2(2))
2558 *     IF(XBJ.LT.0.002D0) IREJ = 1
2559
2560       END
2561
2562 CDECK  ID>, PHO_FIXCOL
2563       SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
2564 C**********************************************************************
2565 C
2566 C     interface to call PHOJET (fixed energy run) with
2567 C     collider kinematics
2568 C
2569 C     equivalen photon approximation to get photon flux
2570 C
2571 C     input:     NEV     number of events to generate
2572 C                THETA   azimuthal angle (micro radians)
2573 C                PHI     beam crossing angle
2574 C                        (with respect to x, in degrees)
2575 C                E1      energy of particle 1 (+z direction, GeV)
2576 C                E2      energy of particle 2 (-z direction, GeV)
2577 C
2578 C     note: particle types have to be specified before
2579 C           with PHO_SETPAR
2580 C
2581 C**********************************************************************
2582       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2583       SAVE
2584
2585       PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
2586
2587 C  input/output channels
2588       INTEGER LI,LO
2589       COMMON /POINOU/ LI,LO
2590 C  event debugging information
2591       INTEGER NMAXD
2592       PARAMETER (NMAXD=100)
2593       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2594      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2595       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2596      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2597 C  general process information
2598       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2599       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2600 C  global event kinematics and particle IDs
2601       INTEGER IFPAP,IFPAB
2602       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2603       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2604 C  model switches and parameters
2605       CHARACTER*8 MDLNA
2606       INTEGER ISWMDL,IPAMDL
2607       DOUBLE PRECISION PARMDL
2608       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2609 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
2610       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2611       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2612       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2613      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2614 C  integration precision for hard cross sections (obsolete)
2615       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2616       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2617 C  event weights and generated cross section
2618       INTEGER IPOWGC,ISWCUT,IVWGHT
2619       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2620       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2621      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2622
2623       DIMENSION P1(4),P2(4)
2624
2625 C  remnant initialization (only needed for DPMJET)
2626       ISAVP1 = IFPAP(1)
2627       ISAVB1 = IFPAB(1)
2628       IF(IFPAP(1).EQ.81) THEN
2629         IFPAP(1) = IDEQP(1)
2630         IFPAB(1) = IDEQB(1)
2631       ENDIF
2632       ISAVP2 = IFPAP(2)
2633       ISAVB2 = IFPAB(2)
2634       IF(IFPAP(2).EQ.82) THEN
2635         IFPAP(2) = IDEQP(2)
2636         IFPAB(2) = IDEQB(2)
2637       ENDIF
2638       PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
2639       PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
2640       PP1 = SQRT(E1**2-PMASS1**2)
2641       PP2 = SQRT(E2**2-PMASS2**2)
2642 C  beam crossing angle
2643       TH = 1.D-6*THETA/2.D0
2644       PH = PHI*BOG
2645       P1(1) = PP1*SIN(TH)*COS(PH)
2646       P1(2) = PP1*SIN(TH)*SIN(PH)
2647       P1(3) = PP1*COS(TH)
2648       P1(4) = E1
2649       P2(1) = PP2*SIN(TH)*COS(PH)
2650       P2(2) = PP2*SIN(TH)*SIN(PH)
2651       P2(3) = -PP2*COS(TH)
2652       P2(4) = E2
2653       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2654       IFPAP(1) = ISAVP1
2655       IFPAB(1) = ISAVB1
2656       IFPAP(2) = ISAVP2
2657       IFPAB(2) = ISAVB2
2658       ITRY = 0
2659       CALL PHO_PHIST(-1,SIGMAX)
2660       CALL PHO_LHIST(-1,SIGMAX)
2661 C  test of DPMJET interface (default is IPAMDL(13)=0)
2662       if(IPAMDL(13).gt.0) then
2663         MODE = IPAMDL(13)
2664         IPAMDL(13) = 0
2665       else
2666         MODE = 1
2667       endif
2668 C  main generation loop
2669       DO 50 I=1,NEV
2670  55     CONTINUE
2671         ITRY = ITRY+1
2672         CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
2673         IF(IREJ.NE.0) GOTO 55
2674         CALL PHO_PHIST(1,HSWGHT(0))
2675         CALL PHO_LHIST(1,HSWGHT(0))
2676  50   CONTINUE
2677
2678       IF(NEV.GT.0) THEN
2679         SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2680         WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2681      &  '=========================================================',
2682      &  ' *****   simulated cross section: ',SIGMAX,' mb  *****',
2683      &  '========================================================='
2684         CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2685         CALL PHO_PHIST(-2,SIGMAX)
2686         CALL PHO_LHIST(-2,SIGMAX)
2687       ELSE
2688         WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
2689       ENDIF
2690
2691       END
2692
2693 CDECK  ID>, PHO_FIXLAB
2694       SUBROUTINE PHO_FIXLAB(PLAB,NEV)
2695 C**********************************************************************
2696 C
2697 C     interface to call PHOJET (fixed energy run) with
2698 C     LAB kinematics (second particle as target)
2699 C
2700 C     equivalent photon approximation to get photon flux
2701 C
2702 C     input:     NEV     number of events to generate
2703 C                PLAB    LAB momentum of particle 1
2704 C
2705 C     note: particle types have to be specified before
2706 C           with PHO_SETPAR
2707 C
2708 C**********************************************************************
2709       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2710       SAVE
2711
2712 C  input/output channels
2713       INTEGER LI,LO
2714       COMMON /POINOU/ LI,LO
2715 C  event debugging information
2716       INTEGER NMAXD
2717       PARAMETER (NMAXD=100)
2718       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2719      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2720       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2721      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2722 C  general process information
2723       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2724       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2725 C  global event kinematics and particle IDs
2726       INTEGER IFPAP,IFPAB
2727       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2728       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2729 C  model switches and parameters
2730       CHARACTER*8 MDLNA
2731       INTEGER ISWMDL,IPAMDL
2732       DOUBLE PRECISION PARMDL
2733       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2734 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
2735       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2736       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2737       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2738      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2739 C  integration precision for hard cross sections (obsolete)
2740       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2741       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2742 C  event weights and generated cross section
2743       INTEGER IPOWGC,ISWCUT,IVWGHT
2744       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2745       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2746      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2747
2748       DIMENSION P1(4),P2(4)
2749
2750 C  remnant initialization (only needed for DPMJET)
2751       SPCM = PLAB
2752       ISAVP1 = IFPAP(1)
2753       ISAVB1 = IFPAB(1)
2754       IF(IFPAP(1).EQ.81) THEN
2755         IFPAP(1) = IDEQP(1)
2756         IFPAB(1) = IDEQB(1)
2757       ENDIF
2758       ISAVP2 = IFPAP(2)
2759       ISAVB2 = IFPAB(2)
2760       IF(IFPAP(2).EQ.82) THEN
2761         IFPAP(2) = IDEQP(2)
2762         IFPAB(2) = IDEQB(2)
2763       ENDIF
2764 C  get momenta in LAB system
2765       PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
2766       PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
2767       IF(PMASS2.LT.0.1D0) THEN
2768         WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
2769      &    'no LAB system possible',IFPAB(1),IFPAB(2)
2770       ELSE
2771         P1(1) = 0.D0
2772         P1(2) = 0.D0
2773         P1(3) = PLAB
2774         P1(4) = SQRT(PMASS1+PLAB**2)
2775         P2(1) = 0.D0
2776         P2(2) = 0.D0
2777         P2(3) = 0.D0
2778         P2(4) = SQRT(PMASS2)
2779         CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2780         IFPAP(1) = ISAVP1
2781         IFPAB(1) = ISAVB1
2782         IFPAP(2) = ISAVP2
2783         IFPAB(2) = ISAVB2
2784         ITRY = 0
2785         CALL PHO_PHIST(-1,SIGMAX)
2786         CALL PHO_LHIST(-1,SIGMAX)
2787 C  event generation loop
2788         DO 40 I=1,NEV
2789  45       CONTINUE
2790           ITRY = ITRY+1
2791           CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
2792           IF(IREJ.NE.0) GOTO 45
2793           CALL PHO_LHIST(1,HSWGHT(0))
2794
2795           CALL PHO_PHIST(10,HSWGHT(0))
2796
2797  40     CONTINUE
2798         IF(NEV.GT.0) THEN
2799           SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2800           WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2801      &    '=========================================================',
2802      &    ' *****   simulated cross section: ',SIGMAX,' mb  *****',
2803      &    '========================================================='
2804           CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2805           CALL PHO_PHIST(-2,SIGMAX)
2806           CALL PHO_LHIST(-2,SIGMAX)
2807         ELSE
2808           WRITE(LO,'(1X,A,I5)')
2809      &      'PHO_FIXLAB: no events simulated',NEV
2810         ENDIF
2811       ENDIF
2812
2813       END
2814
2815 CDECK  ID>, PHO_GPHERA
2816       SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
2817 C**********************************************************************
2818 C
2819 C     interface to call PHOJET (variable energy run) with
2820 C     HERA kinematics, photon as particle 2
2821 C
2822 C     equivalent photon approximation to get photon flux
2823 C
2824 C     input:     NEVENT  number of events to generate
2825 C                EE1     proton energy (LAB system)
2826 C                EE2     electron energy (LAB system)
2827 C             from /POFCUT/:
2828 C                YMIN2    lower limit of Y
2829 C                        (energy fraction taken by photon from electron)
2830 C                YMAX2    upper limit of Y
2831 C                Q2MIN2   lower limit of photon virtuality
2832 C                Q2MAX2   upper limit of photon virtuality
2833 C
2834 C**********************************************************************
2835       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2836       SAVE
2837
2838       PARAMETER ( DEPS = 1.D-10,
2839      &            PI   = 3.14159265359D0 )
2840
2841 C  input/output channels
2842       INTEGER LI,LO
2843       COMMON /POINOU/ LI,LO
2844 C  event debugging information
2845       INTEGER NMAXD
2846       PARAMETER (NMAXD=100)
2847       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2848      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2849       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2850      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2851 C  model switches and parameters
2852       CHARACTER*8 MDLNA
2853       INTEGER ISWMDL,IPAMDL
2854       DOUBLE PRECISION PARMDL
2855       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2856 C  photon flux kinematics and cuts
2857       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
2858      &                 YMIN1,YMAX1,YMIN2,YMAX2,
2859      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2860      &                 THMIN1,THMAX1,THMIN2,THMAX2
2861       INTEGER          ITAG1,ITAG2
2862       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
2863      &                YMIN1,YMAX1,YMIN2,YMAX2,
2864      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2865      &                THMIN1,THMAX1,THMIN2,THMAX2,
2866      &                ITAG1,ITAG2
2867 C  gamma-lepton or gamma-hadron vertex information
2868       INTEGER IGHEL,IDPSRC,IDBSRC
2869       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2870      &                 RADSRC,AMSRC,GAMSRC
2871       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2872      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2873      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2874 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
2875       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2876       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2877       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2878      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2879 C  event weights and generated cross section
2880       INTEGER IPOWGC,ISWCUT,IVWGHT
2881       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2882       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2883      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2884
2885       DIMENSION P1(4),P2(4)
2886
2887       WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
2888 C  assign particle momenta according to HERA kinematics
2889 C  proton data
2890       PROM = PHO_PMASS(2212,1)
2891       PROM2 = PROM**2
2892       IDPSRC(1) = 0
2893       IDBSRC(1) = 0
2894 C  electron data
2895       ELEM = 0.512D-03
2896       ELEM2 = ELEM**2
2897       AMSRC(2) = ELEM
2898       IDPSRC(2) = 11
2899       IDBSRC(2) = ipho_pdg2id(11)
2900 C
2901       Q2MIN = Q2MIN2
2902       Q2MAX = Q2MAX2
2903 C
2904       XIMAX = LOG(YMAX2)
2905       XIMIN = LOG(YMIN2)
2906       XIDEL = XIMAX-XIMIN
2907 C
2908       IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
2909      &  WRITE(LO,'(/1X,A,1P2E11.4)')
2910      &  'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
2911      &  Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
2912 C
2913       Max_tab = 50
2914       DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
2915       FLUXT = 0.D0
2916       FLUXL = 0.D0
2917       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
2918      &  'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
2919       DO 100 I=1,Max_tab
2920         Y = EXP(XIMIN+DELLY*DBLE(I-1))
2921         Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
2922         FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2923      &         -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
2924         FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
2925         FLUXT = FLUXT + Y*FFT
2926         FLUXL = FLUXL + Y*FFL
2927         IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
2928  100  CONTINUE
2929       FLUXT = FLUXT*DELLY
2930       FLUXL = FLUXL*DELLY
2931       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
2932      &  'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
2933 C
2934       AY = 0.D0
2935       AY2 = 0.D0
2936       YY = YMIN2
2937       Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2938       WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
2939      &        -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
2940       IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
2941 C
2942 C  initialization of PHOJET at upper energy limit
2943 C  proton momentum
2944       P1(1) = 0.D0
2945       P1(2) = 0.D0
2946       P1(3) = SQRT(EE1**2-PROM2+DEPS)
2947       P1(4) = EE1
2948 C  photon momentum
2949       EGAM = YMAX2*EE2
2950       P2(1) = 0.D0
2951       P2(2) = 0.D0
2952       P2(3) = -EGAM
2953       P2(4) = EGAM
2954 C  sum of both photon polarizations
2955       IGHEL(2) = -1
2956 C
2957       CALL PHO_SETPAR(1,2212,0,0.D0)
2958       CALL PHO_SETPAR(2,22,0,0.D0)
2959       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2960       CALL PHO_PHIST(-1,SIGMAX)
2961       CALL PHO_LHIST(-1,SIGMAX)
2962 C
2963 C  generation of events, flux calculation
2964
2965       ECMIN2 = ECMIN**2
2966       ECMAX2 = ECMAX**2
2967       AY = 0.D0
2968       AY2 = 0.D0
2969       Q22MIN = 1.D30
2970       Q22AVE = 0.D0
2971       Q22AV2 = 0.D0
2972       Q22MAX = 0.D0
2973       AN2MIN = 1.D30
2974       AN2MAX = 0.D0
2975       YY2MIN = 1.D30
2976       YY2MAX = 0.D0
2977       NITER = NEVENT
2978       ITRY = 0
2979       ITRW = 0
2980       DO 200 I=1,NITER
2981  150    CONTINUE
2982 C  sample y
2983         ITRY = ITRY+1
2984  175    CONTINUE
2985           ITRW = ITRW+1
2986           YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
2987           IF(ISWMDL(10).GE.2) THEN
2988             YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
2989           ELSE
2990             YEFF = 1.D0+(1.D0-YY)**2
2991           ENDIF
2992           Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2993           Q2LOG = LOG(Q2MAX/Q2LOW)
2994           WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
2995           IF(WGMAX.LT.WGH) THEN
2996             WRITE(LO,'(1X,A,3E12.5)')
2997      &        'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
2998           ENDIF
2999         IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
3000 C  sample Q2
3001         IF(IPAMDL(174).EQ.1) THEN
3002  185      CONTINUE
3003             Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3004             WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
3005           IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
3006         ELSE
3007           Q2 = Q2LOW
3008         ENDIF
3009 C
3010
3011 C  incoming electron
3012         PINI(1,2) = 0.D0
3013         PINI(2,2) = 0.D0
3014         PINI(3,2) = -EE2
3015         PINI(4,2) = EE2
3016         PINI(5,2) = 0.D0
3017 C  outgoing electron
3018         YQ2 = SQRT((1.D0-YY)*Q2)
3019         Q2E = Q2/(4.D0*EE2)
3020         E1Y = EE2*(1.D0-YY)
3021         CALL PHO_SFECFE(SIF,COF)
3022         PFIN(1,2) = YQ2*COF
3023         PFIN(2,2) = YQ2*SIF
3024         PFIN(3,2) = -E1Y+Q2E
3025         PFIN(4,2) = E1Y+Q2E
3026         PFIN(5,2) = 0.D0
3027 C  set /POFSRC/
3028         GYY(2) = YY
3029         GQ2(2) = Q2
3030 C  polar angle
3031         PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3032 C  electron tagger
3033         IF(PFIN(4,2).GT.EEMIN2) THEN
3034           IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
3035         ENDIF
3036 C  azimuthal angle
3037         PFPHI(2) = ATAN2(COF,SIF)
3038 C  photon momentum
3039         P2(1) = -PFIN(1,2)
3040         P2(2) = -PFIN(2,2)
3041         P2(3) = PINI(3,2)-PFIN(3,2)
3042         P2(4) = PINI(4,2)-PFIN(4,2)
3043 C  proton momentum
3044         P1(1) = 0.D0
3045         P1(2) = 0.D0
3046         P1(3) = SQRT(EE1**2-PROM2)
3047         P1(4) = EE1
3048 C  ECMS cut
3049         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3050      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3051         IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
3052         GGECM = SQRT(GGECM)
3053 C
3054         PGAM(1,2) = P2(1)
3055         PGAM(2,2) = P2(2)
3056         PGAM(3,2) = P2(3)
3057         PGAM(4,2) = P2(4)
3058         PGAM(5,2) = -SQRT(Q2)
3059 C  photon helicity
3060         IF(ISWMDL(10).GE.2) THEN
3061           WGH  = YEFF-2.D0*ELEM2*YY**2/Q2
3062           WGHL = 2.D0*(1-YY)
3063           IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
3064             IGHEL(2) = 1
3065           ELSE
3066             IGHEL(2) = 0
3067           ENDIF
3068         ELSE
3069           IGHEL(2) = -1
3070         ENDIF
3071 C  user cuts
3072         CALL PHO_PRESEL(5,IREJ)
3073         IF(IREJ.NE.0) GOTO 175
3074 C  event generation
3075         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3076         IF(IREJ.NE.0) GOTO 150
3077
3078 C  statistics
3079         AY = AY+YY
3080         AY2 = AY2+YY*YY
3081         YY2MIN = MIN(YY2MIN,YY)
3082         YY2MAX = MAX(YY2MAX,YY)
3083         Q22MIN = MIN(Q22MIN,Q2)
3084         Q22MAX = MAX(Q22MAX,Q2)
3085         Q22AVE = Q22AVE+Q2
3086         Q22AV2 = Q22AV2+Q2*Q2
3087         AN2MIN = MIN(AN2MIN,PFTHE(2))
3088         AN2MAX = MAX(AN2MAX,PFTHE(2))
3089 C  histograms
3090         CALL PHO_PHIST(1,HSWGHT(0))
3091         CALL PHO_LHIST(1,HSWGHT(0))
3092  200  CONTINUE
3093 C
3094       WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
3095       WGY = WGY*LOG(YMAX2/YMIN2)
3096       AY  = AY/DBLE(NITER)
3097       AY2 = AY2/DBLE(NITER)
3098       DAY = SQRT((AY2-AY**2)/DBLE(NITER))
3099       Q22AVE = Q22AVE/DBLE(NITER)
3100       Q22AV2 = Q22AV2/DBLE(NITER)
3101       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3102       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
3103 C  output of histograms
3104       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3105      &'=========================================================',
3106      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
3107      &'========================================================='
3108       WRITE(LO,'(//1X,A,3I10)')
3109      &  'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
3110       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
3111      &  WGY,WEIGHT
3112       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY                 ',AY,DAY
3113       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON       ',
3114      &  YY2MIN,YY2MAX
3115       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2               ',
3116      &  Q22AVE,Q22AV2
3117       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON      ',
3118      &  Q22MIN,Q22MAX
3119       WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
3120      &  AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3121 C
3122       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3123       IF(NITER.GT.1) THEN
3124         CALL PHO_PHIST(-2,WEIGHT)
3125         CALL PHO_LHIST(-2,WEIGHT)
3126       ELSE
3127         WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
3128       ENDIF
3129
3130       END
3131
3132 CDECK  ID>, PHO_GGEPEM
3133       SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
3134 C**********************************************************************
3135 C
3136 C     interface to call PHOJET (variable energy run) for
3137 C     gamma-gamma collisions on e+e- collider
3138 C
3139 C     fully differential equivalent (improved) photon approximation
3140 C     to get photon flux
3141 C
3142 C     input:     EE1     LAB system energy of electron/positron 1
3143 C                EE2     LAB system energy of electron/positron 2
3144 C                NEVENT  >0  number of events to generate
3145 C                        -1   initialization
3146 C                        -2   final call (cross section calculation)
3147 C            from /LEPCUT/:
3148 C                YMIN1   lower limit of Y1
3149 C                        (energy fraction taken by photon from electron)
3150 C                YMAX1   upper limit of Y1
3151 C                Q2MIN1  lower limit of photon virtuality
3152 C                Q2MAX1  upper limit of photon virtuality
3153 C                THMIN1  lower limit of scattered electron
3154 C                THMAX1  upper limit of scattered electron
3155 C                YMIN2   lower limit of Y2
3156 C                        (energy fraction taken by photon from electron)
3157 C                YMAX2   upper limit of Y2
3158 C                Q2MIN2  lower limit of photon virtuality
3159 C                Q2MAX2  upper limit of photon virtuality
3160 C                THMIN2  lower limit of scattered electron
3161 C                THMAX2  upper limit of scattered electron
3162 C
3163 C     output:    after final call with NEVENT=-2
3164 C                EE1     e+ e- cross section (mb)
3165 C                EE2     gamma-gamma cross section (mb)
3166 C
3167 C**********************************************************************
3168
3169       IMPLICIT NONE
3170
3171       SAVE
3172
3173       DOUBLE PRECISION EE1,EE2
3174       INTEGER NEVENT
3175
3176 C  input/output channels
3177       INTEGER LI,LO
3178       COMMON /POINOU/ LI,LO
3179 C  event debugging information
3180       INTEGER NMAXD
3181       PARAMETER (NMAXD=100)
3182       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3183      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3184       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3185      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3186 C  model switches and parameters
3187       CHARACTER*8 MDLNA
3188       INTEGER ISWMDL,IPAMDL
3189       DOUBLE PRECISION PARMDL
3190       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3191 C  some constants
3192       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3193       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3194      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3195 C  photon flux kinematics and cuts
3196       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
3197      &                 YMIN1,YMAX1,YMIN2,YMAX2,
3198      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3199      &                 THMIN1,THMAX1,THMIN2,THMAX2
3200       INTEGER          ITAG1,ITAG2
3201       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
3202      &                YMIN1,YMAX1,YMIN2,YMAX2,
3203      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3204      &                THMIN1,THMAX1,THMIN2,THMAX2,
3205      &                ITAG1,ITAG2
3206 C  gamma-lepton or gamma-hadron vertex information
3207       INTEGER IGHEL,IDPSRC,IDBSRC
3208       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3209      &                 RADSRC,AMSRC,GAMSRC
3210       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3211      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3212      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3213 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3214       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3215       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3216       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3217      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3218 C  event weights and generated cross section
3219       INTEGER IPOWGC,ISWCUT,IVWGHT
3220       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
3221       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
3222      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
3223
3224 C  external functions
3225       DOUBLE PRECISION DT_RNDM
3226
3227 C  local variables
3228       DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
3229      &  COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
3230      &  ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
3231      &  FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
3232      &  Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
3233      &  Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
3234      &  THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
3235      &  WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
3236      &  YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
3237
3238       INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
3239      &  ITRY_high,K,Max_tab,NITER,ITG1,ITG2
3240
3241       DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
3242       integer ipho_pdg2id
3243
3244 C  initialization of event generation
3245
3246       if(NEVENT.eq.-1) then
3247
3248         DO 10 I=1,4
3249           IHETRY(I) = 0
3250           IHEAC1(I) = 0
3251           IHEAC2(I) = 0
3252  10     CONTINUE
3253
3254         WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
3255
3256 C  electron data
3257         ELEM = 0.512D-03
3258         ELEM2 = ELEM**2
3259         AMSRC(1) = ELEM
3260         AMSRC(2) = ELEM
3261 C  lepton numbers
3262         IDPSRC(1) = 11
3263         IDPSRC(2) = -11
3264         IDBSRC(1) = ipho_pdg2id(11)
3265         IDBSRC(2) = ipho_pdg2id(-11)
3266
3267 C  check/update kinematic limitations
3268
3269         Ymi = min(Ymax1,1.D0-ELEM/EE1)
3270         if(Ymi.lt.Ymax1) then
3271           WRITE(LO,'(/1X,A,2E12.5)')
3272      &      'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
3273           Ymax1 = YMI
3274         endif
3275         Ymi = min(Ymax2,1.D0-ELEM/EE2)
3276         if(Ymi.lt.Ymax2) then
3277           WRITE(LO,'(/1X,A,2E12.5)')
3278      &      'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
3279           Ymax2 = YMI
3280         endif
3281
3282         YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
3283         IF(YMIN1.LT.YMI) THEN
3284           WRITE(LO,'(/1X,A,2E12.5)')
3285      &      'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
3286           YMIN1 = YMI
3287         ELSE IF(YMIN1.GT.YMI) THEN
3288           WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3289      &      'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
3290      &      '  INSTEAD OF',YMIN1
3291         ENDIF
3292         YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
3293         IF(YMIN2.LT.YMI) THEN
3294           WRITE(LO,'(/1X,A,2E12.5)')
3295      &      'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
3296           YMIN2 = YMI
3297         ELSE IF(YMIN2.GT.YMI) THEN
3298           WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3299      &      'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
3300      &      '  INSTEAD OF',YMIN2
3301         ENDIF
3302
3303 C  store COS of angular tagging range
3304         THMIC1 = COS(MAX(0.D0,THMIN1))
3305         THMAC1 = COS(MIN(THMAX1,PI))
3306         THMIC2 = COS(MAX(0.D0,THMIN2))
3307         THMAC2 = COS(MIN(THMAX2,PI))
3308
3309         X1MAX = LOG(YMAX1)
3310         X1MIN = LOG(YMIN1)
3311         X1DEL = X1MAX-X1MIN
3312         X2MAX = LOG(YMAX2)
3313         X2MIN = LOG(YMIN2)
3314         X2DEL = X2MAX-X2MIN
3315
3316 C  debug: integrated photon flux
3317
3318         if(IDEB(30).ge.1) then
3319           Max_tab = 50
3320           FLUXT = 0.D0
3321           FLUXL = 0.D0
3322           DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
3323           IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
3324      &      'table of photon flux (trans/long side 1)',Max_tab
3325           do I=1,Max_tab
3326             Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
3327             if((1.D0-Y1).gt.1.D-8) then
3328               Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
3329             else
3330               Q2low1 = 2.D0*Q2max1
3331             endif
3332             if(Q2low1.lt.Q2max1) then
3333               FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
3334      &        -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
3335               FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
3336             else
3337               FFT = 0.D0
3338               FFL = 0.D0
3339             endif
3340             FLUXT = FLUXT + Y1*FFL
3341             FLUXL = FLUXL + Y1*FFT
3342             IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
3343           enddo
3344           FLUXT = FLUXT*DELLY
3345           FLUXL = FLUXL*DELLY
3346           WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
3347      &      'integrated flux (trans/long side 1):',FLUXT,FLUXL
3348         endif
3349
3350 C  maximum weight
3351
3352         Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
3353         Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
3354         Y1 = YMIN1
3355         Y2 = YMIN2
3356         IF(ISWMDL(10).GE.2) THEN
3357 C  long. and transversely polarized photons
3358           WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
3359      &           -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3360      &           *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
3361      &           -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3362         ELSE
3363 C  transversely polarized photons only
3364           WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
3365      &           -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3366      &           *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
3367      &           -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3368         ENDIF
3369
3370 C  initialize gamma-gamma event generator
3371
3372 C  photon 1
3373         EGAM = YMAX1*EE1
3374         P1(1) = 0.D0
3375         P1(2) = 0.D0
3376         P1(3) = SQRT(EGAM**2-Q2LOW1)
3377         P1(4) = EGAM
3378 C  photon 2
3379         EGAM = YMAX2*EE2
3380         P2(1) = 0.D0
3381         P2(2) = 0.D0
3382         P2(3) = -SQRT(EGAM**2-Q2LOW2)
3383         P2(4) = EGAM
3384 C  sum of helicities
3385         IGHEL(1) = -1
3386         IGHEL(2) = -1
3387
3388 C  set min. energy for interpolation tables
3389         parmdl(19) = min(parmdl(19),ecmin)
3390
3391 C  initialize event gneration
3392         CALL PHO_SETPAR(1,22,0,0.D0)
3393         CALL PHO_SETPAR(2,22,0,0.D0)
3394         CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
3395         CALL PHO_PHIST(-1,SIGMAX)
3396         CALL PHO_LHIST(-1,SIGMAX)
3397
3398 C  generation of events, flux calculation
3399
3400         ECMIN2 = ECMIN**2
3401         ECMAX2 = ECMAX**2
3402         ECFRAC = ECMIN2/(4.D0*EE1*EE2)
3403         AY1  = 0.D0
3404         AY2  = 0.D0
3405         AYS1 = 0.D0
3406         AYS2 = 0.D0
3407         Q21MIN = 1.D30
3408         Q22MIN = 1.D30
3409         Q21MAX = 0.D0
3410         Q22MAX = 0.D0
3411         Q21AVE = 0.D0
3412         Q22AVE = 0.D0
3413         Q21AV2 = 0.D0
3414         Q22AV2 = 0.D0
3415         AN1MIN = 1.D30
3416         AN2MIN = 1.D30
3417         AN1MAX = 0.D0
3418         AN2MAX = 0.D0
3419         YY1MIN = 1.D30
3420         YY2MIN = 1.D30
3421         YY1MAX = 0.D0
3422         YY2MAX = 0.D0
3423         NITER = 0
3424         ITRY_low = 0
3425         ITRY_high = 0
3426         ITRW_low = 0
3427         ITRW_high = 0
3428
3429 C  generate NEVENT events (might be just 1 per call)
3430
3431       else if(NEVENT.gt.0) then
3432
3433         NITER = NITER+NEVENT
3434
3435         DO 200 I=1,NEVENT
3436
3437 C  sample y1, y2
3438  150      CONTINUE
3439           ITRY_low = ITRY_low+1
3440           if(ITRY_low.eq.1000000) then
3441             ITRY_low = 0
3442             ITRY_high = ITRY_high+1
3443           endif
3444
3445  175      CONTINUE
3446             ITRW_low = ITRW_low+1
3447             if(ITRW_low.eq.1000000) then
3448               ITRW_low = 0
3449               ITRW_high = ITRW_high+1
3450             endif
3451
3452             Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
3453             Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
3454             IF(Y1*Y2.LT.ECFRAC) GOTO 175
3455             IF(ISWMDL(10).GE.2) THEN
3456               YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
3457               YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
3458             ELSE
3459               YEFF1 = 1.D0+(1.D0-Y1)**2
3460               YEFF2 = 1.D0+(1.D0-Y2)**2
3461             ENDIF
3462
3463             Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
3464             Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
3465             Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
3466             Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
3467             WGH = (YEFF1*Q2LOG1
3468      &             -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3469      &           *(YEFF2*Q2LOG2
3470      &             -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3471             IF(WGMAX.LT.WGH) THEN
3472               WRITE(LO,'(1X,A,4E12.5)')
3473      &          'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
3474             ENDIF
3475           IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
3476
3477 C  limit on Ecm_gg (app. cut, precise cut applied later)
3478           GGECM2 = 4.D0*Y1*Y2*EE1*EE2
3479           if(GGECM2.lt.ECMIN2) goto 175
3480
3481 C  sample Q2
3482           IF(IPAMDL(174).EQ.1) THEN
3483  185        CONTINUE
3484               Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
3485               WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
3486             IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
3487           ELSE
3488             Q2P1 = Q2LOW1
3489           ENDIF
3490
3491           IF(IPAMDL(174).EQ.1) THEN
3492  186        CONTINUE
3493               Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
3494               WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
3495             IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
3496           ELSE
3497             Q2P2 = Q2LOW2
3498           ENDIF
3499
3500           GYY(1) = Y1
3501           GQ2(1) = Q2P1
3502           GYY(2) = Y2
3503           GQ2(2) = Q2P2
3504
3505 C  incoming electron 1
3506           PINI(1,1) = 0.D0
3507           PINI(2,1) = 0.D0
3508           PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
3509           PINI(4,1) = EE1
3510           PINI(5,1) = ELEM
3511 C  photon 1
3512           PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
3513           PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
3514      &         -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
3515           IF(PT2.LT.0.D0) GOTO 175
3516           PT = SQRT(PT2)
3517           CALL PHO_SFECFE(SIF1,COF1)
3518           P1(1) = COF1*PT
3519           P1(2) = SIF1*PT
3520           P1(3) = PP
3521           P1(4) = EE1*Y1
3522 C  outgoing electron 1
3523           PFIN(1,1) = -P1(1)
3524           PFIN(2,1) = -P1(2)
3525           PFIN(3,1) = PINI(3,1)-P1(3)
3526           PFIN(4,1) = PINI(4,1)-P1(4)
3527           PFIN(5,1) = ELEM
3528 C  incoming electron 2
3529           PINI(1,2) = 0.D0
3530           PINI(2,2) = 0.D0
3531           PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
3532           PINI(4,2) = EE2
3533           PINI(5,2) = 0.D0
3534 C  photon 2
3535           PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
3536           PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
3537      &         -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
3538           IF(PT2.LT.0.D0) GOTO 175
3539           PT = SQRT(PT2)
3540           CALL PHO_SFECFE(SIF2,COF2)
3541           P2(1) = COF2*PT
3542           P2(2) = SIF2*PT
3543           P2(3) = PP
3544           P2(4) = EE2*Y2
3545 C  outgoing electron 2
3546           PFIN(1,2) = -P2(1)
3547           PFIN(2,2) = -P2(2)
3548           PFIN(3,2) = PINI(3,2)-P2(3)
3549           PFIN(4,2) = PINI(4,2)-P2(4)
3550           PFIN(5,2) = ELEM
3551
3552 C  precise ECMS cut
3553
3554           GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3555      &           -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3556           IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
3557           GGECM = SQRT(GGECM2)
3558
3559 C  beam lepton detector acceptance
3560
3561 C  lepton tagger 1
3562           CPFTHE = PFIN(3,1)/PFIN(4,1)
3563           ITG1 = 0
3564           IF(PFIN(4,1).GE.EEMIN1) THEN
3565             IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
3566           ENDIF
3567
3568 C  lepton tagger 2
3569           CPFTHE = PFIN(3,2)/PFIN(4,2)
3570           ITG2 = 0
3571           IF(PFIN(4,2).GE.EEMIN2) THEN
3572             IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
3573           ENDIF
3574
3575 C  beam lepton taggers
3576
3577 C  anti-tag
3578           IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
3579           IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
3580 C  tag
3581           IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
3582           IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
3583 C  single-tag inclusive
3584           IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
3585      &      GOTO 175
3586 C  single-tag/anti-tag
3587           IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
3588      &      GOTO 175
3589
3590           PGAM(1,1) = P1(1)
3591           PGAM(2,1) = P1(2)
3592           PGAM(3,1) = P1(3)
3593           PGAM(4,1) = P1(4)
3594           PGAM(5,1) = -SQRT(Q2P1)
3595           PGAM(1,2) = P2(1)
3596           PGAM(2,2) = P2(2)
3597           PGAM(3,2) = P2(3)
3598           PGAM(4,2) = P2(4)
3599           PGAM(5,2) = -SQRT(Q2P2)
3600
3601 C  photon helicities
3602           IF(ISWMDL(10).GE.2) THEN
3603             WGH  = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
3604             WGHL = 2.D0*(1-Y1)
3605             IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
3606               IGHEL(1) = 1
3607             ELSE
3608               IGHEL(1) = 0
3609             ENDIF
3610             WGH  = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
3611             WGHL = 2.D0*(1-Y2)
3612             IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
3613               IGHEL(2) = 1
3614             ELSE
3615               IGHEL(2) = 0
3616             ENDIF
3617             K = 2*IGHEL(1)+IGHEL(2)+1
3618             IHETRY(K) = IHETRY(K)+1
3619           ELSE
3620             IGHEL(1) = -1
3621             IGHEL(2) = -1
3622           ENDIF
3623
3624 C  user cuts
3625           CALL PHO_PRESEL(5,IREJ)
3626           IF(IREJ.NE.0) GOTO 175
3627
3628           WGFX = 1.D0
3629 C  reweight according to LO photon emission diagrams (Budnev et al.)
3630           IF(IPAMDL(116).GE.1) THEN
3631             CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
3632             WGFX = FLXQPM/FLXAPP
3633             if(WGFX.gt.1.D0) then
3634               WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
3635      &          ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
3636      &          Y1,Y2,Q2P1,Q2P2,GGECM
3637             endif
3638           ENDIF
3639
3640 C  event generation
3641 *         IVWGHT(1) = 1
3642 *         EVWGHT(1) = MAX(WGFX,1.D0)
3643           CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3644           IF(IREJ.NE.0) GOTO 150
3645           IF(ISWMDL(10).GE.2) THEN
3646             K = 2*IGHEL(1)+IGHEL(2)+1
3647             IHEAC1(K) = IHEAC1(K)+1
3648           ENDIF
3649
3650 C  reweight according to QPM model (e+e- collider only)
3651           IF((KHDIR.GT.0).AND.
3652      &      (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
3653             CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
3654             WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
3655             IF(DT_RNDM(WG).GT.WG) GOTO 150
3656           ELSE IF(IPAMDL(116).GE.1) THEN
3657             IF(DT_RNDM(WG).GT.WGFX) GOTO 150
3658           ENDIF
3659
3660 C  polar angle
3661           PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
3662           PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3663 C  azimuthal angle
3664           PFPHI(1) = ATAN2(COF1,SIF1)
3665           PFPHI(2) = ATAN2(COF2,SIF2)
3666
3667 C  statistics
3668           AY1  = AY1+Y1
3669           AYS1 = AYS1+Y1*Y1
3670           AY2  = AY2+Y2
3671           AYS2 = AYS2+Y2*Y2
3672           Q21MIN = MIN(Q21MIN,Q2P1)
3673           Q22MIN = MIN(Q22MIN,Q2P2)
3674           Q21MAX = MAX(Q21MAX,Q2P1)
3675           Q22MAX = MAX(Q22MAX,Q2P2)
3676           AN1MIN = MIN(AN1MIN,PFTHE(1))
3677           AN2MIN = MIN(AN2MIN,PFTHE(2))
3678           AN1MAX = MAX(AN1MAX,PFTHE(1))
3679           AN2MAX = MAX(AN2MAX,PFTHE(2))
3680           YY1MIN = MIN(YY1MIN,Y1)
3681           YY2MIN = MIN(YY2MIN,Y2)
3682           YY1MAX = MAX(YY1MAX,Y1)
3683           YY2MAX = MAX(YY2MAX,Y2)
3684           Q21AVE = Q21AVE+Q2P1
3685           Q22AVE = Q22AVE+Q2P2
3686           Q21AV2 = Q21AV2+Q2P1*Q2P1
3687           Q22AV2 = Q22AV2+Q2P2*Q2P2
3688           IF(ISWMDL(10).GE.2) THEN
3689             K = 2*IGHEL(1)+IGHEL(2)+1
3690             IHEAC2(K) = IHEAC2(K)+1
3691           ENDIF
3692
3693 C  external histograms
3694           CALL PHO_PHIST(1,HSWGHT(0))
3695           CALL PHO_LHIST(1,HSWGHT(0))
3696  200    CONTINUE
3697
3698 C  final cross section calculation and event generation summary
3699
3700       else if(NEVENT.eq.-2) then
3701
3702 *       EVWGHT(1) = 1.D0
3703 *       IVWGHT(1) = 0
3704         DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
3705         DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
3706         WGY  = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
3707         WGY  = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
3708         AY1  = AY1/DBLE(NITER)
3709         AYS1 = AYS1/DBLE(NITER)
3710         DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
3711         AY2  = AY2/DBLE(NITER)
3712         AYS2 = AYS2/DBLE(NITER)
3713         DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
3714         Q21AVE = Q21AVE/DBLE(NITER)
3715         Q21AV2 = Q21AV2/DBLE(NITER)
3716         Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
3717         Q22AVE = Q22AVE/DBLE(NITER)
3718         Q22AV2 = Q22AV2/DBLE(NITER)
3719         Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3720         WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
3721         EE1 = WEIGHT
3722         EE2 = SIGMAX*DBLE(NITER)/DITRY
3723
3724 C  output of statistics, histograms
3725         WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3726      &    '=========================================================',
3727      &    ' *****   simulated cross section: ',WEIGHT,' mb  *****',
3728      &    '========================================================='
3729         WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
3730      &    'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
3731         WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
3732      &    WGY,WEIGHT
3733         WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1               ',
3734      &    AY1,DAY1
3735         WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2               ',
3736      &    AY2,DAY2
3737         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1     ',
3738      &    YY1MIN,YY1MAX
3739         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2     ',
3740      &    YY2MIN,YY2MAX
3741         WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1      ',
3742      &    Q21AVE,Q21AV2
3743         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1    ',
3744      &    Q21MIN,Q21MAX
3745         WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2  photon 2     ',
3746      &    Q22AVE,Q22AV2
3747         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2    ',
3748      &    Q22MIN,Q22MAX
3749         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
3750      &    AN1MIN,AN1MAX
3751         WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
3752      &    AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3753
3754         IF(ISWMDL(10).GE.2) THEN
3755           WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
3756      &    'Helicity decomposition:    0 0      0 1      1 0       1 1',
3757      &    'tried:        ',IHETRY,
3758      &    'accepted (1): ',IHEAC1,
3759      &    'accepted (2): ',IHEAC2
3760         ENDIF
3761
3762         CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3763         IF(NITER.GT.1) THEN
3764           CALL PHO_PHIST(-2,WEIGHT)
3765           CALL PHO_LHIST(-2,WEIGHT)
3766         ELSE
3767           WRITE(LO,'(1X,A,I4)')
3768      &      'PHO_GGEPEM: no output of histograms',NITER
3769         ENDIF
3770
3771       endif
3772
3773       END
3774
3775 CDECK  ID>, PHO_WGEPEM
3776       SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
3777 C**********************************************************************
3778 C
3779 C     calculate cross section weights for
3780 C      fully differential equivalent (improved) photon approximation
3781 C     and/or
3782 C      fully differential QPM model with exact one-photon exchange graphs
3783 C
3784 C     (unpolarized lepton beams)
3785 C
3786 C     input:     IMODE     0   flux calculation only
3787 C                          1   flux folded with QPM cross section
3788 C                /POFSRC/  photon and electron momenta
3789 C                /POPRCS/  process type
3790 C                /POCKIN/  kinematics of hard scattering
3791 C
3792 C     output:    WGHAPP  weight of event according to approximation
3793 C                WGHQPM  weight of event according to one-photon exchange
3794 C
3795 C**********************************************************************
3796
3797       IMPLICIT NONE
3798
3799       SAVE
3800
3801       DOUBLE PRECISION WGHAPP,WGHQPM
3802       INTEGER IMODE
3803
3804 C  input/output channels
3805       INTEGER LI,LO
3806       COMMON /POINOU/ LI,LO
3807 C  event debugging information
3808       INTEGER NMAXD
3809       PARAMETER (NMAXD=100)
3810       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3811      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3812       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3813      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3814 C  model switches and parameters
3815       CHARACTER*8 MDLNA
3816       INTEGER ISWMDL,IPAMDL
3817       DOUBLE PRECISION PARMDL
3818       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3819 C  some constants
3820       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3821       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3822      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3823 C  gamma-lepton or gamma-hadron vertex information
3824       INTEGER IGHEL,IDPSRC,IDBSRC
3825       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3826      &                 RADSRC,AMSRC,GAMSRC
3827       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3828      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3829      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3830 C  general process information
3831       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3832       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3833 C  data on most recent hard scattering
3834       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3835       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3836      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
3837      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
3838       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3839      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
3840      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
3841      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
3842      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3843 C  hard scattering parameters used for most recent hard interaction
3844       INTEGER NFbeta,NF
3845       DOUBLE PRECISION ALQCD2,BQCD
3846       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
3847 C  currently activated parton density parametrizations
3848       CHARACTER*8 PDFNAM
3849       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
3850       DOUBLE PRECISION PDFLAM,PDFQ2M
3851       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
3852      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
3853
3854 C  standard particle data interface
3855       INTEGER NMXHEP
3856
3857       PARAMETER (NMXHEP=4000)
3858
3859       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
3860       DOUBLE PRECISION PHEP,VHEP
3861       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
3862      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
3863      &                VHEP(4,NMXHEP)
3864 C  extension to standard particle data interface (PHOJET specific)
3865       INTEGER IMPART,IPHIST,ICOLOR
3866       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
3867
3868       DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
3869      &  P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
3870      &  RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
3871      &  SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
3872      &  TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
3873      &  XM2,XQ2,XTM1,XTM2,XTM3,YCAP
3874       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
3875
3876       INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
3877
3878       DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
3879       DIMENSION HELFLX(6),SIGQPM(6)
3880
3881       WGHAPP = 1.D0
3882       WGHQPM = 0.D0
3883
3884 C  strict pt cutoff after putting partons on mass shell,
3885 C  calculated in gamma-gamma CMS
3886       if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
3887         if(PTfin.lt.PTwant) then
3888           if(ipamdl(121).gt.1) return
3889           if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
3890         endif
3891       endif
3892
3893 C  cross section of sampled event (approximate treatment)
3894
3895 C  photon flux
3896       DO 50 K=1,2
3897         XM2(K) = AMSRC(K)**2
3898         IF(abs(IGHEL(K)).EQ.1) THEN
3899           WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
3900      &              -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
3901         ELSE
3902           WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
3903         ENDIF
3904  50   CONTINUE
3905
3906       W2 = GGECM*GGECM
3907       IDIR   = 0
3908       WGHQQ  = 1.D0
3909
3910 C  direct or single-resolved gam-gam interaction
3911       IF((IMODE.GE.1).AND.
3912      &   (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
3913         IDIR   = 1
3914         WGHQQ = 0.D0
3915 C  determine final state partons
3916         DO 100 I=3,NHEP
3917           IF(ISTHEP(I).EQ.25) GOTO 110
3918  100    CONTINUE
3919         WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
3920      &    'inconsistent process information (MSPR)',MSPR
3921         CALL PHO_ABORT
3922  110    CONTINUE
3923         IPOS = I
3924 C  final state flavors
3925         IPFL1 = ABS(IDHEP(IPOS+3))
3926         IPFL2 = ABS(IDHEP(IPOS+4))
3927         SH = X1*X2*W2
3928 C  calculate alpha-em
3929         ALPHA1 = pho_alphae(QQAL)
3930 C  calculate alpha-s
3931         IF(MSPR.LT.14) THEN
3932           ALPHA2 = PHO_ALPHAS(QQAL,3)
3933         ENDIF
3934 C  LO matrix element (8 pi s dsig/dt)
3935 *       QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
3936         QC2 = Q_ch2(IPFL2)
3937         IF(IPFL2.EQ.0) THEN
3938           WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
3939      &      'invalid hard process - flavor combination',
3940      &      'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
3941         ENDIF
3942         IF(MSPR.EQ.10) THEN
3943           WGHQQ  = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
3944      &            *8.D0*PI*SH
3945         ELSE IF(MSPR.EQ.11) THEN
3946           WGHQQ  = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3947      &            *8.D0*PI*SH
3948         ELSE IF(MSPR.EQ.12) THEN
3949           WGHQQ  = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
3950      &            *8.D0*PI*SH
3951         ELSE IF(MSPR.EQ.13) THEN
3952           WGHQQ  = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3953      &            *8.D0*PI*SH
3954         ELSE IF(MSPR.EQ.14) THEN
3955           WGHQQ  = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
3956      &            *8.D0*PI*SH
3957         ENDIF
3958       ENDIF
3959
3960 C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3961       WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
3962
3963 C  full leading-order QPM prediction (Budnev et al.)
3964
3965 C  full two-gamma flux
3966
3967       P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
3968      &      -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
3969       P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
3970      &      -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
3971       Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
3972      &      -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
3973       P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
3974      &      -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
3975       DO 120 I=1,4
3976         P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
3977         P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
3978  120  CONTINUE
3979       XTM1 = 2.D0*P1Q2-Q1Q2
3980       XTM2 = 2.D0*P2Q1-Q1Q2
3981       XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
3982       XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
3983       YCAP = P1P2**2-XM2(1)*XM2(2)
3984       CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
3985
3986       RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
3987       RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
3988       RHO100 = XTM1**2/XCAP-1.D0
3989       RHO200 = XTM2**2/XCAP-1.D0
3990       RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
3991       RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
3992       SS     = 2.D0*P1P2+XM2(1)+XM2(2)
3993
3994       HELFLX(1) = 4.D0*RHO1PP*RHO2PP
3995       HELFLX(2) = RHOPM2
3996       HELFLX(3) = 2.D0*RHO1PP*RHO200
3997       HELFLX(4) = 2.D0*RHO100*RHO2PP
3998       HELFLX(5) = RHO100*RHO200
3999       HELFLX(6) = -RHOP08
4000
4001 C  only flux calculation
4002
4003       IF(IDIR.EQ.0) THEN
4004         IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4005           WEIGHT = HELFLX(1)
4006         ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4007           WEIGHT = HELFLX(3)
4008         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4009           WEIGHT = HELFLX(4)
4010         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4011           WEIGHT = HELFLX(5)
4012         ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
4013           WEIGHT = HELFLX(1)
4014         ELSE
4015           WRITE(LO,'(/1X,A,2I3)')
4016      &      'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4017           WRITE(LO,'(1X,A,I12)')
4018      &      'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4019           WEIGHT = 0.D0
4020         ENDIF
4021
4022 C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4023         WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4024      &          *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4025
4026       ELSE
4027
4028 C  flux folded with cross section
4029 C  polarized, leading order gam gam --> q qbar cross sections
4030
4031         DO 125 I=1,6
4032           SIGQPM(I) = 0.D0
4033  125    CONTINUE
4034 C  momenta of produced parton pair
4035         I1 = IPOS+3
4036         I2 = IPOS+4
4037         DO 150 K=1,4
4038           XK1(K) = PHEP(K,I1)
4039           XK2(K) = PHEP(K,I2)
4040  150    CONTINUE
4041         XQ2 = PHEP(5,I2)**2
4042
4043         IF(MSPR.EQ.14) THEN
4044 C  direct photon-photon interaction
4045           XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
4046      &          +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
4047      &          +(PGAM(3,1)-XK1(3))**2
4048           XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
4049      &          +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
4050      &          +(PGAM(3,1)-XK2(3))**2
4051           CC = Q1Q2
4052           AA = XKAP*XKAM-GQ2(1)*GQ2(2)
4053           BB = CC**2-XKAP*XKAM
4054           DD = CC**2-GQ2(1)*GQ2(2)
4055           RR = -XQ2+W2*AA/(4.D0*DD)
4056           Q1KK = Q1Q2-GQ2(1)
4057           Q2KK = Q1Q2-GQ2(2)
4058           FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
4059
4060         ELSE
4061 C  single-resolved photon-hadron interactions
4062 C  Mandelstam variables
4063           IF(MSPR.LE.11) THEN
4064             TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
4065      &          -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
4066             UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
4067      &          -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
4068           ELSE
4069             TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
4070      &          -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
4071             UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
4072      &          -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
4073           ENDIF
4074           V = TH/SH
4075           U = UH/SH
4076         ENDIF
4077
4078         WEIGHT = 0.D0
4079         IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4080           IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
4081             IF(MSPR.EQ.10) THEN
4082               Q2 = -GQ2(1)
4083               SP = SH-XQ2
4084               TP = UH-XQ2
4085             ELSE
4086               Q2 = -GQ2(2)
4087               SP = SH-XQ2
4088               TP = TH-XQ2
4089             ENDIF
4090             SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
4091      &        *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
4092      &        +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
4093      &       -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
4094      &        -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
4095      &        (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
4096      &        4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
4097      &        (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
4098             WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4099           ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
4100             IF(MSPR.EQ.11) THEN
4101               Q2 = -GQ2(1)
4102             ELSE
4103               Q2 = -GQ2(2)
4104             ENDIF
4105             SP = SH
4106             TP = UH
4107             SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
4108      &        *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
4109      &        - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
4110      &            (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
4111      &        (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
4112      &         4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
4113      &        +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
4114      &        *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
4115      &        SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
4116      &        (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
4117      &        *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
4118      &        +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
4119      &        *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
4120      &        2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
4121      &        (Q2-SP-TP+XQ2)**2)
4122             WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4123           ELSE IF(MSPR.EQ.14) THEN
4124             SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
4125             SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
4126             SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
4127      &              -2.D0*XKAP*XKAM*AA
4128             SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
4129             SIGQPM(2) = SWPPMM*FAC
4130             WEIGHT = HELFLX(1)*SIGQPM(1)
4131      &              +HELFLX(2)*SIGQPM(2)
4132           ENDIF
4133         ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4134           IF(MSPR.EQ.12) THEN
4135             Q2 = -GQ2(2)
4136             SP = SH-XQ2
4137             TP = TH-XQ2
4138             SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4139      &               *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4140      &               SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4141      &               TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4142      &               2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4143      &               2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4144      &               XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4145      &               (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4146             WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4147           ELSE IF(MSPR.EQ.13) THEN
4148             Q2 = -GQ2(2)
4149             SP = SH
4150             TP = TH
4151             SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4152      &        *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4153      &        SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4154             WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4155           ELSE IF(MSPR.EQ.14) THEN
4156             SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
4157      &              -XKAP*XKAM*Q1KK**2)/DD
4158             SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
4159             SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4160      &              *SQRT(GQ2(1)*GQ2(2))/DD
4161             SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4162      &              +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4163             SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4164      &              *SQRT(GQ2(1)*GQ2(2))/DD
4165             SIGQPM(3) = SWP0P0*FAC
4166             SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4167             WEIGHT = HELFLX(3)*SIGQPM(3)
4168      &              +HELFLX(6)*SIGQPM(6)/2.D0
4169           ENDIF
4170         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4171           IF(MSPR.EQ.10) THEN
4172             Q2 = -GQ2(1)
4173             SP = SH-XQ2
4174             TP = UH-XQ2
4175             SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4176      &               *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4177      &               SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4178      &               TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4179      &               2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4180      &               2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4181      &               XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4182      &               (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4183             WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
4184           ELSE IF(MSPR.EQ.11) THEN
4185             Q2 = -GQ2(1)
4186             SP = SH
4187             TP = TH
4188             SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4189      &        *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4190      &        SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4191             WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
4192           ELSE IF(MSPR.EQ.14) THEN
4193             SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
4194      &                               -XKAP*XKAM*Q2KK**2)/DD
4195             SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
4196             SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4197      &              *SQRT(GQ2(1)*GQ2(2))/DD
4198             SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4199      &              +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4200             SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4201      &              *SQRT(GQ2(1)*GQ2(2))/DD
4202             SIGQPM(4) = SW0P0P*FAC
4203             SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4204             WEIGHT = HELFLX(4)*SIGQPM(4)
4205      &              +HELFLX(6)*SIGQPM(6)/2.D0
4206           ENDIF
4207         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4208           IF(MSPR.EQ.14) THEN
4209             SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
4210             SIGQPM(5) = SW0000*FAC
4211             WEIGHT = HELFLX(5)*SIGQPM(5)
4212           ENDIF
4213         ELSE
4214           WRITE(LO,'(/1X,A,2I3)')
4215      &      'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4216           WRITE(LO,'(1X,A,I12)')
4217      &      'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4218           WEIGHT = 0.D0
4219         ENDIF
4220
4221 C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4222
4223         WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4224      &          *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4225
4226       ENDIF
4227
4228       END
4229
4230 CDECK  ID>, PHO_GGBLSR
4231       SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
4232      &                      Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
4233 C***********************************************************************
4234 C
4235 C     interface to call PHOJET (variable energy run) for
4236 C     gamma-gamma collisions via laser backscattering
4237 C
4238 C     input:     EE1         lab. system energy of electron/positron 1
4239 C                EE2         lab. system energy of electron/positron 2
4240 C                NEVENT      number of events to generate
4241 C                Pl_lam_1/2  product of electron and photon pol.
4242 C                X_1/2       standard X parameter
4243 C                rho         ratio of distance to conversion point and
4244 C                            transverse beam size
4245 C                A           ellipticity of electon beam
4246 C
4247 C                (see Ginzburg & Kotkin hep-ph/9905462)
4248 C
4249 C            from /LEPCUT/:
4250 C                YMIN1   lower limit of Y1
4251 C                        (energy fraction taken by photon from electron)
4252 C                YMAX1   upper limit of Y1
4253 C                YMIN2   lower limit of Y2
4254 C                        (energy fraction taken by photon from electron)
4255 C                YMAX2   upper limit of Y2
4256 C
4257 C***********************************************************************
4258       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4259       SAVE
4260
4261       PARAMETER ( PI   = 3.14159265359D0 )
4262
4263 C  input/output channels
4264       INTEGER LI,LO
4265       COMMON /POINOU/ LI,LO
4266 C  event debugging information
4267       INTEGER NMAXD
4268       PARAMETER (NMAXD=100)
4269       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4270      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4271       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4272      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4273 C  photon flux kinematics and cuts
4274       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4275      &                 YMIN1,YMAX1,YMIN2,YMAX2,
4276      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4277      &                 THMIN1,THMAX1,THMIN2,THMAX2
4278       INTEGER          ITAG1,ITAG2
4279       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4280      &                YMIN1,YMAX1,YMIN2,YMAX2,
4281      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4282      &                THMIN1,THMAX1,THMIN2,THMAX2,
4283      &                ITAG1,ITAG2
4284 C  gamma-lepton or gamma-hadron vertex information
4285       INTEGER IGHEL,IDPSRC,IDBSRC
4286       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4287      &                 RADSRC,AMSRC,GAMSRC
4288       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4289      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4290      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4291 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
4292       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4293       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4294       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4295      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4296 C  event weights and generated cross section
4297       INTEGER IPOWGC,ISWCUT,IVWGHT
4298       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4299       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4300      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4301
4302       parameter (N_dim=100)
4303       dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
4304      &          X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
4305      &          Xgrid(96),Wgrid(96)
4306
4307       DIMENSION P1(4),P2(4)
4308
4309       Pi2 = 2.D0*Pi
4310
4311       WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
4312
4313       YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
4314       YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
4315       IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
4316         WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
4317      &    'invalid Ymin1,Ymin2',YMIN1,YMIN2
4318         RETURN
4319       ENDIF
4320       IDPSRC(1) = 0
4321       IDBSRC(1) = 0
4322       IDPSRC(2) = 0
4323       IDBSRC(2) = 0
4324
4325 C  initialize sampling
4326
4327       Max_tab = 50
4328       DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
4329       DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
4330
4331       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4332      &  'PHO_GGBLSR: table of photon flux ',Max_tab
4333
4334       DO 100 I=1,Max_tab
4335
4336         y1 = YMIN1+DELY1*DBLE(I-1)
4337         r1 = y1/(X_1*(1.D0-y1))
4338         X_inp_1(i) = y1
4339         F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
4340      &            -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
4341
4342         y2 = YMIN2+DELY2*DBLE(I-1)
4343         r2 = y2/(X_2*(1.D0-y2))
4344         X_inp_2(i) = y2
4345         F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
4346      &            -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
4347
4348         IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
4349      &    y1,F_inp_1(i),y2,F_inp_2(i)
4350
4351  100  CONTINUE
4352
4353       call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4354       call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4355
4356 C  initialize event generator
4357
4358 C  photon 1
4359       EGAM = YMAX1*EE1
4360       P1(1) = 0.D0
4361       P1(2) = 0.D0
4362       P1(3) = EGAM
4363       P1(4) = EGAM
4364 C  photon 2
4365       EGAM = YMAX2*EE2
4366       P2(1) = 0.D0
4367       P2(2) = 0.D0
4368       P2(3) = -EGAM
4369       P2(4) = EGAM
4370       CALL PHO_SETPAR(1,22,0,0.D0)
4371       CALL PHO_SETPAR(2,22,0,0.D0)
4372       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4373       CALL PHO_PHIST(-1,SIGMAX)
4374       CALL PHO_LHIST(-1,SIGMAX)
4375
4376 C  generation of events
4377
4378       AY1  = 0.D0
4379       AY2  = 0.D0
4380       AYS1 = 0.D0
4381       AYS2 = 0.D0
4382       NITER = NEVENT
4383       ITRY = 0
4384       ITRW = 0
4385       DO 200 I=1,NITER
4386  150    CONTINUE
4387         ITRY = ITRY+1
4388  175    CONTINUE
4389           ITRW = ITRW+1
4390
4391           call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4392           call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4393
4394           g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
4395           g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
4396           if(abs(1.D0-A).lt.1.D-3) then
4397             v = rho**2/4.D0*g_1*g_2
4398             Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
4399           else
4400             Nint = 16
4401             call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
4402             A2 = A**2
4403             fac = rho**2/(4.D0*(1.D0+A2))
4404             Wght = 0.D0
4405             do i1=1,Nint
4406               phi_1 = Xgrid(i1)
4407               do i2=1,Nint
4408                 phi_2 = Xgrid(i2)
4409                 Wght = Wght
4410      &            +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
4411      &                         +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
4412      &            *Wgrid(i1)*Wgrid(i2)
4413               enddo
4414             enddo
4415             Wght = Wght/Pi2**2
4416           endif
4417
4418           IF(Wght.GT.1.D0) THEN
4419             WRITE(LO,'(1X,A,5E11.4)')
4420      &        'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
4421           ENDIF
4422         IF(DT_RNDM(dum).GT.Wght) GOTO 175
4423
4424         Y1 = X_out_1
4425         Y2 = X_out_2
4426
4427         Q2P1 = 0.D0
4428         Q2P2 = 0.D0
4429         GYY(1) = Y1
4430         GQ2(1) = Q2P1
4431         GYY(2) = Y2
4432         GQ2(2) = Q2P2
4433 C  incoming electron 1
4434         PINI(1,1) = 0.D0
4435         PINI(2,1) = 0.D0
4436         PINI(3,1) = EE1
4437         PINI(4,1) = EE1
4438         PINI(5,1) = 0.D0
4439 C  outgoing electron 1
4440         YQ2 = SQRT((1.D0-Y1)*Q2P2)
4441         Q2E = Q2P1/(4.D0*EE1)
4442         E1Y = EE1*(1.D0-Y1)
4443         CALL PHO_SFECFE(SIF,COF)
4444         PFIN(1,1) = YQ2*COF
4445         PFIN(2,1) = YQ2*SIF
4446         PFIN(3,1) = E1Y-Q2E
4447         PFIN(4,1) = E1Y+Q2E
4448         PFIN(5,1) = 0.D0
4449 C  photon 1
4450         P1(1) = -PFIN(1,1)
4451         P1(2) = -PFIN(2,1)
4452         P1(3) = PINI(3,1)-PFIN(3,1)
4453         P1(4) = PINI(4,1)-PFIN(4,1)
4454 C  incoming electron 2
4455         PINI(1,2) = 0.D0
4456         PINI(2,2) = 0.D0
4457         PINI(3,2) = -EE2
4458         PINI(4,2) = EE2
4459         PINI(5,2) = 0.D0
4460 C  outgoing electron 2
4461         YQ2 = SQRT((1.D0-Y2)*Q2P2)
4462         Q2E = Q2P2/(4.D0*EE2)
4463         E1Y = EE2*(1.D0-Y2)
4464         CALL PHO_SFECFE(SIF,COF)
4465         PFIN(1,2) = YQ2*COF
4466         PFIN(2,2) = YQ2*SIF
4467         PFIN(3,2) = -E1Y+Q2E
4468         PFIN(4,2) = E1Y+Q2E
4469         PFIN(5,2) = 0.D0
4470 C  photon 2
4471         P2(1) = -PFIN(1,2)
4472         P2(2) = -PFIN(2,2)
4473         P2(3) = PINI(3,2)-PFIN(3,2)
4474         P2(4) = PINI(4,2)-PFIN(4,2)
4475 C  ECMS cut
4476         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4477      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4478         IF(GGECM.LT.0.1D0) GOTO 175
4479         GGECM = SQRT(GGECM)
4480         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4481
4482         PGAM(1,1) = P1(1)
4483         PGAM(2,1) = P1(2)
4484         PGAM(3,1) = P1(3)
4485         PGAM(4,1) = P1(4)
4486         PGAM(5,1) = 0.D0
4487         PGAM(1,2) = P2(1)
4488         PGAM(2,2) = P2(2)
4489         PGAM(3,2) = P2(3)
4490         PGAM(4,2) = P2(4)
4491         PGAM(5,2) = 0.D0
4492 C  photon helicities
4493         IGHEL(1) = 1
4494         IGHEL(2) = 1
4495 C  cut given by user
4496         CALL PHO_PRESEL(5,IREJ)
4497         IF(IREJ.NE.0) GOTO 175
4498 C  event generation
4499         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4500         IF(IREJ.NE.0) GOTO 150
4501
4502 C  statistics
4503         AY1  = AY1+Y1
4504         AYS1 = AYS1+Y1*Y1
4505         AY2  = AY2+Y2
4506         AYS2 = AYS2+Y2*Y2
4507 C  histograms
4508         CALL PHO_PHIST(1,HSWGHT(0))
4509         CALL PHO_LHIST(1,HSWGHT(0))
4510  200  CONTINUE
4511
4512       WGY  = DBLE(ITRY)/DBLE(ITRW)
4513       AY1  = AY1/DBLE(NITER)
4514       AYS1 = AYS1/DBLE(NITER)
4515       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4516       AY2  = AY2/DBLE(NITER)
4517       AYS2 = AYS2/DBLE(NITER)
4518       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4519       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4520 C  output of statistics, histograms
4521       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4522      &'=========================================================',
4523      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
4524      &'========================================================='
4525       WRITE(LO,'(//1X,A,3I10)')
4526      &  'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
4527       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4528      &  WGY,WEIGHT
4529       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
4530       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
4531
4532       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4533       IF(NITER.GT.1) THEN
4534         CALL PHO_PHIST(-2,WEIGHT)
4535         CALL PHO_LHIST(-2,WEIGHT)
4536       ELSE
4537         WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
4538       ENDIF
4539
4540       END
4541
4542 CDECK  ID>, pho_samp1d
4543       SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
4544 C***********************************************************************
4545 C
4546 C     Monte Carlo sampling from arbitrary 1d distribution
4547 C     (linear interpolation to improve reproduction of initial function)
4548 C
4549 C     input: Imode          -1  initialization
4550 C                            1  sampling (after initialization)
4551 C            X_inp(N_dim)   array with x values
4552 C            F_inp(N_dim)   array with function values
4553 C            F_int(N_dim)   array with integral
4554 C
4555 C     output:  X_out        sampled value (Imode=1)
4556 C
4557 C                                                 (R.E. 10/99)
4558 C
4559 C***********************************************************************
4560       implicit none
4561       save
4562
4563 C  input/output channels
4564       INTEGER LI,LO
4565       COMMON /POINOU/ LI,LO
4566
4567       integer Imode,N_dim
4568       double precision X_inp,F_inp,F_int,X_out
4569       dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
4570
4571 C  local variables
4572       integer i
4573       double precision dum,xi,a,b
4574
4575 C  external functions
4576       double precision DT_RNDM
4577       external DT_RNDM
4578
4579       if(Imode.eq.-1) then
4580
4581 C  initialization
4582
4583         F_int(1) = 0.D0
4584         do i=2,N_dim
4585           F_int(i) = F_int(i-1)
4586      &       +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
4587         enddo
4588
4589       else if(Imode.eq.1) then
4590
4591 C  sample from previously calculated integral
4592
4593         xi = DT_RNDM(dum)*F_int(N_dim)
4594
4595         do i=2,N_dim
4596           if(xi.lt.F_int(i)) then
4597             a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
4598             b = F_inp(i)-a*X_inp(i)
4599             xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
4600             X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
4601             return
4602           endif
4603         enddo
4604         X_out = X_inp(N_dim)
4605
4606       else
4607
4608 C  invalid option Imode
4609
4610         WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
4611         X_out = 0.D0
4612
4613       endif
4614
4615       END
4616
4617 CDECK  ID>, pho_ExpBessI0
4618       DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
4619 C**********************************************************************
4620 C
4621 C     Bessel Function I0 times exponential function from neg. arg.
4622 C     (defined for pos. arguments only)
4623 C
4624 C**********************************************************************
4625       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4626       SAVE
4627
4628       AX = ABS(X)
4629       IF (AX .LT. 3.75D0) THEN
4630         Y = (X/3.75D0)**2
4631         pho_ExpBessI0 =
4632      &    (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
4633      &    +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
4634       ELSE
4635         Y = 3.75D0/AX
4636         pho_ExpBessI0 =
4637      &    (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
4638      &    +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
4639      &    +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
4640      &    +Y*0.392377D-2))))))))
4641       ENDIF
4642
4643       END
4644
4645 CDECK  ID>, PHO_GGBEAM
4646       SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
4647 C**********************************************************************
4648 C
4649 C     interface to call PHOJET (variable energy run) for
4650 C     gamma-gamma collisions via beamstrahlung
4651 C
4652 C     input:     EE      LAB system energy of electron/positron
4653 C                YPSI    beamstrahlung parameter
4654 C                SIGX,Y  transverse bunch dimensions
4655 C                SIGZ    longitudinal bunch dimension
4656 C                AEB     number of electrons/positrons in a bunch
4657 C                NEVENT  number of events to generate
4658 C            from /LEPCUT/:
4659 C                YMIN1   lower limit of Y
4660 C                        (energy fraction taken by photon from electron)
4661 C                YMAX1   upper cutoff for Y, necessary to avoid
4662 C                        underflows
4663 C
4664 C**********************************************************************
4665       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4666       SAVE
4667
4668       PARAMETER ( DEPS = 1.D-20,
4669      &            PI   = 3.14159265359D0 )
4670
4671 C  input/output channels
4672       INTEGER LI,LO
4673       COMMON /POINOU/ LI,LO
4674 C  event debugging information
4675       INTEGER NMAXD
4676       PARAMETER (NMAXD=100)
4677       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4678      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4679       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4680      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4681 C  photon flux kinematics and cuts
4682       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4683      &                 YMIN1,YMAX1,YMIN2,YMAX2,
4684      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4685      &                 THMIN1,THMAX1,THMIN2,THMAX2
4686       INTEGER          ITAG1,ITAG2
4687       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4688      &                YMIN1,YMAX1,YMIN2,YMAX2,
4689      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4690      &                THMIN1,THMAX1,THMIN2,THMAX2,
4691      &                ITAG1,ITAG2
4692 C  gamma-lepton or gamma-hadron vertex information
4693       INTEGER IGHEL,IDPSRC,IDBSRC
4694       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4695      &                 RADSRC,AMSRC,GAMSRC
4696       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4697      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4698      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4699 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
4700       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4701       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4702       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4703      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4704 C  event weights and generated cross section
4705       INTEGER IPOWGC,ISWCUT,IVWGHT
4706       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4707       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4708      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4709
4710       PARAMETER (Max_tab=100)
4711       DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
4712
4713 C
4714       WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
4715 C  electron data
4716       RE = 2.818D-12
4717       ELEM = 0.512D-03
4718       IDPSRC(1) = 0
4719       IDBSRC(1) = 0
4720       IDPSRC(2) = 0
4721       IDBSRC(2) = 0
4722 C  table of flux function, log interpolation
4723       IF(YPSI.LE.0.D0) THEN
4724         YPSI  = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
4725       ENDIF
4726       WRITE(LO,'(/1X,A,E12.4)')
4727      &  'PHO_GGBEAM: beamstrahlung parameter:',YPSI
4728       WRITE(LO,'(/1X,A,2E12.4)')
4729      &  'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
4730       TT    = 2.D0/3.D0
4731       OT    = 1.D0/3.D0
4732 C     GAOT  = DGAMMA(OT)
4733       GAOT  = 2.6789385347D0
4734       AKAP  = TT/YPSI
4735       WW    = 1.D0/(6.D0*SQRT(AKAP))
4736       ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
4737      &       *YPSI/SQRT(1.D0+YPSI**TT)
4738
4739       YMIN = YMIN1
4740       YMAX = MIN(YMAX1,0.9D0)
4741       TABCU(0) = 0.D0
4742       TABYL(0) = LOG(YMIN)
4743       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
4744       FLUX = 0.D0
4745       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4746      &  'PHO_GGBEAM: table of photon flux',Max_tab
4747       DO 100 I=1,Max_tab
4748         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
4749         GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
4750         FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
4751      &      *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
4752      &      +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
4753         TABCU(I) = TABCU(I-1)+FF*Y
4754         TABYL(I) = LOG(Y)
4755         FLUX = FLUX+Y*FF
4756         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
4757  100  CONTINUE
4758       FLUX = FLUX*DELLY
4759       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
4760      &  'PHO_GGBEAM: integrated flux (one side):',FLUX
4761
4762       EE1 = EE
4763       EE2 = EE
4764 C  photon 1
4765       EGAM = YMAX*EE
4766       P1(1) = 0.D0
4767       P1(2) = 0.D0
4768       P1(3) = EGAM
4769       P1(4) = EGAM
4770 C  photon 2
4771       EGAM = YMAX*EE
4772       P2(1) = 0.D0
4773       P2(2) = 0.D0
4774       P2(3) = -EGAM
4775       P2(4) = EGAM
4776       CALL PHO_SETPAR(1,22,0,0.D0)
4777       CALL PHO_SETPAR(2,22,0,0.D0)
4778       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4779       CALL PHO_PHIST(-1,SIGMAX)
4780       CALL PHO_LHIST(-1,SIGMAX)
4781
4782 C  generation of events
4783
4784       AY1  = 0.D0
4785       AY2  = 0.D0
4786       AYS1 = 0.D0
4787       AYS2 = 0.D0
4788       NITER = NEVENT
4789       ITRY = 0
4790       ITRW = 0
4791       DO 200 I=1,NITER
4792  150    CONTINUE
4793         ITRY = ITRY+1
4794  175    CONTINUE
4795         ITRW = ITRW+1
4796         XI = DT_RNDM(AY1)*TABCU(Max_tab)
4797         DO 110 K=1,Max_tab
4798           IF(TABCU(K).GE.XI) THEN
4799             Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4800             Y1 = EXP(Y1)
4801             GOTO 120
4802           ENDIF
4803  110    CONTINUE
4804         Y1 = YMAX
4805  120    CONTINUE
4806         XI = DT_RNDM(AY2)*TABCU(Max_tab)
4807         DO 130 K=1,Max_tab
4808           IF(TABCU(K).GE.XI) THEN
4809             Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4810             Y2 = EXP(Y2)
4811             GOTO 140
4812           ENDIF
4813  130    CONTINUE
4814         Y2 = YMAX
4815  140    CONTINUE
4816
4817         Q2P1 = 0.D0
4818         Q2P2 = 0.D0
4819         GYY(1) = Y1
4820         GQ2(1) = Q2P1
4821         GYY(2) = Y2
4822         GQ2(2) = Q2P2
4823 C  incoming electron 1
4824         PINI(1,1) = 0.D0
4825         PINI(2,1) = 0.D0
4826         PINI(3,1) = EE1
4827         PINI(4,1) = EE1
4828         PINI(5,1) = 0.D0
4829 C  outgoing electron 1
4830         YQ2 = SQRT((1.D0-Y1)*Q2P2)
4831         Q2E = Q2P1/(4.D0*EE1)
4832         E1Y = EE1*(1.D0-Y1)
4833         CALL PHO_SFECFE(SIF,COF)
4834         PFIN(1,1) = YQ2*COF
4835         PFIN(2,1) = YQ2*SIF
4836         PFIN(3,1) = E1Y-Q2E
4837         PFIN(4,1) = E1Y+Q2E
4838         PFIN(5,1) = 0.D0
4839 C  photon 1
4840         P1(1) = -PFIN(1,1)
4841         P1(2) = -PFIN(2,1)
4842         P1(3) = PINI(3,1)-PFIN(3,1)
4843         P1(4) = PINI(4,1)-PFIN(4,1)
4844 C  incoming electron 2
4845         PINI(1,2) = 0.D0
4846         PINI(2,2) = 0.D0
4847         PINI(3,2) = -EE2
4848         PINI(4,2) = EE2
4849         PINI(5,2) = 0.D0
4850 C  outgoing electron 2
4851         YQ2 = SQRT((1.D0-Y2)*Q2P2)
4852         Q2E = Q2P2/(4.D0*EE2)
4853         E1Y = EE2*(1.D0-Y2)
4854         CALL PHO_SFECFE(SIF,COF)
4855         PFIN(1,2) = YQ2*COF
4856         PFIN(2,2) = YQ2*SIF
4857         PFIN(3,2) = -E1Y+Q2E
4858         PFIN(4,2) = E1Y+Q2E
4859         PFIN(5,2) = 0.D0
4860 C  photon 2
4861         P2(1) = -PFIN(1,2)
4862         P2(2) = -PFIN(2,2)
4863         P2(3) = PINI(3,2)-PFIN(3,2)
4864         P2(4) = PINI(4,2)-PFIN(4,2)
4865 C  ECMS cut
4866         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4867      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4868         IF(GGECM.LT.0.1D0) GOTO 175
4869         GGECM = SQRT(GGECM)
4870         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4871 C
4872         PGAM(1,1) = P1(1)
4873         PGAM(2,1) = P1(2)
4874         PGAM(3,1) = P1(3)
4875         PGAM(4,1) = P1(4)
4876         PGAM(5,1) = 0.D0
4877         PGAM(1,2) = P2(1)
4878         PGAM(2,2) = P2(2)
4879         PGAM(3,2) = P2(3)
4880         PGAM(4,2) = P2(4)
4881         PGAM(5,2) = 0.D0
4882 C  photon helicities
4883         IGHEL(1) = 1
4884         IGHEL(2) = 1
4885 C  cut given by user
4886         CALL PHO_PRESEL(5,IREJ)
4887         IF(IREJ.NE.0) GOTO 175
4888 C  event generation
4889         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4890         IF(IREJ.NE.0) GOTO 150
4891         GGECML = LOG(GGECM)
4892
4893 C  statistics
4894         AY1  = AY1+Y1
4895         AYS1 = AYS1+Y1*Y1
4896         AY2  = AY2+Y2
4897         AYS2 = AYS2+Y2*Y2
4898 C  histograms
4899         CALL PHO_PHIST(1,HSWGHT(0))
4900         CALL PHO_LHIST(1,HSWGHT(0))
4901  200  CONTINUE
4902 C
4903       WGY  = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
4904       AY1  = AY1/DBLE(NITER)
4905       AYS1 = AYS1/DBLE(NITER)
4906       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4907       AY2  = AY2/DBLE(NITER)
4908       AYS2 = AYS2/DBLE(NITER)
4909       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4910       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4911 C  output of statistics, histograms
4912       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4913      &'=========================================================',
4914      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
4915      &'========================================================='
4916       WRITE(LO,'(//1X,A,2I10)')
4917      &  'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
4918       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4919      &  WGY,WEIGHT
4920       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
4921       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
4922 C
4923       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4924       IF(NITER.GT.1) THEN
4925         CALL PHO_PHIST(-2,WEIGHT)
4926         CALL PHO_LHIST(-2,WEIGHT)
4927       ELSE
4928         WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
4929       ENDIF
4930
4931       END
4932
4933 CDECK  ID>, PHO_GGHIOF
4934       SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
4935 C**********************************************************************
4936 C
4937 C     interface to call PHOJET (variable energy run) for
4938 C     gamma-gamma collisions via heavy ions (form factor approach)
4939 C
4940 C     input:     EEN     LAB system energy per nucleon
4941 C                NA      atomic number of ion/hadron
4942 C                NZ      charge number of ion/hadron
4943 C                NEVENT  number of events to generate
4944 C            from /LEPCUT/:
4945 C                YMIN1,2 lower limit of Y
4946 C                        (energy fraction taken by photon from hadron)
4947 C                YMAX1,2 upper cutoff for Y, necessary to avoid
4948 C                        underflows
4949 C                Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
4950 C                Q2MAX1,2 maximum Q**2 of photons (if necessary,
4951 C                        corrected according size of hadron)
4952 C
4953 C      currently implemented approximation similar to:
4954 C                E.Papageorgiu PhysLettB250(1990)155
4955 C
4956 C**********************************************************************
4957       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4958       SAVE
4959
4960       PARAMETER ( PI   = 3.14159265359D0 )
4961
4962 C  input/output channels
4963       INTEGER LI,LO
4964       COMMON /POINOU/ LI,LO
4965 C  model switches and parameters
4966       CHARACTER*8 MDLNA
4967       INTEGER ISWMDL,IPAMDL
4968       DOUBLE PRECISION PARMDL
4969       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4970 C  event debugging information
4971       INTEGER NMAXD
4972       PARAMETER (NMAXD=100)
4973       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4974      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4975       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4976      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4977 C  photon flux kinematics and cuts
4978       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4979      &                 YMIN1,YMAX1,YMIN2,YMAX2,
4980      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4981      &                 THMIN1,THMAX1,THMIN2,THMAX2
4982       INTEGER          ITAG1,ITAG2
4983       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4984      &                YMIN1,YMAX1,YMIN2,YMAX2,
4985      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4986      &                THMIN1,THMAX1,THMIN2,THMAX2,
4987      &                ITAG1,ITAG2
4988 C  gamma-lepton or gamma-hadron vertex information
4989       INTEGER IGHEL,IDPSRC,IDBSRC
4990       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4991      &                 RADSRC,AMSRC,GAMSRC
4992       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4993      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4994      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4995 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
4996       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4997       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4998       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4999      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5000 C  event weights and generated cross section
5001       INTEGER IPOWGC,ISWCUT,IVWGHT
5002       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5003       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5004      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5005
5006       DIMENSION P1(4),P2(4),BIMP(2,2)
5007
5008 C
5009       WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
5010      &                      '--------------------------------------'
5011 C  hadron size and mass
5012       FM2GEV = 5.07D0
5013       HIMASS = DBLE(NA)*0.938D0
5014       HIMA2  = HIMASS**2
5015       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5016       ALPHA  = DBLE(NZ**2)/137.D0
5017 C  correct Q2MAX1,2 according to hadron size
5018       Q2MAXH = 2.D0/HIRADI**2
5019       Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
5020       Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
5021       IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
5022       IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
5023 C  total hadron / heavy ion energy
5024       EE = EEN*DBLE(NA)
5025       GAMMA = EE/HIMASS
5026 C  setup /POFSRC/
5027       GAMSRC(1) = GAMMA
5028       GAMSRC(2) = GAMMA
5029       RADSRC(1) = HIRADI
5030       RADSRC(2) = HIRADI
5031       AMSRC(1)  = HIMASS
5032       AMSRC(1)  = HIMASS
5033 C  kinematic limitations
5034       YMI = (ECMIN/(2.D0*EE))**2
5035       IF(YMIN1.LT.YMI) THEN
5036         WRITE(LO,'(/1X,A,2E12.5)')
5037      &    'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
5038         YMIN1 = YMI
5039       ELSE IF(YMIN1.GT.YMI) THEN
5040         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5041      &    'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5042      &    '  INSTEAD OF',YMIN1
5043       ENDIF
5044       IF(YMIN2.LT.YMI) THEN
5045         WRITE(LO,'(/1X,A,2E12.5)')
5046      &    'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
5047         YMIN2 = YMI
5048       ELSE IF(YMIN2.GT.YMI) THEN
5049         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5050      &    'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5051      &    '  INSTEAD OF',YMIN2
5052       ENDIF
5053 C  kinematic limitation
5054       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5055       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5056 C  debug output
5057       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
5058       WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
5059       WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
5060       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
5061      &  Q2MAX1
5062       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
5063      &  Q2MAX2
5064       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
5065      &  YMAX1
5066       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
5067      &  YMAX2
5068       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
5069      &  2.D0*EEN,2.D0*EE
5070       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
5071       IF(Q2LOW1.GE.Q2MAX1) THEN
5072         WRITE(LO,'(/1X,A,2E12.4)')
5073      &    'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
5074         CALL PHO_ABORT
5075       ENDIF
5076       IF(Q2LOW2.GE.Q2MAX2) THEN
5077         WRITE(LO,'(/1X,A,2E12.4)')
5078      &    'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
5079         CALL PHO_ABORT
5080       ENDIF
5081 C  hadron numbers set to 0
5082       IDPSRC(1) = 0
5083       IDPSRC(2) = 0
5084       IDBSRC(1) = 0
5085       IDBSRC(2) = 0
5086 C
5087       Max_tab = 100
5088       YMAX = YMAX1
5089       YMIN = YMIN1
5090       XMAX = LOG(YMAX)
5091       XMIN = LOG(YMIN)
5092       XDEL = XMAX-XMIN
5093       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5094       DO 100 I=1,Max_tab
5095         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5096         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5097         IF(Q2LOW1.GE.Q2MAX1) THEN
5098           WRITE(LO,'(/1X,A,2E12.4)')
5099      &      'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
5100           YMAX1 = MIN(Y1,YMAX1)
5101           GOTO 101
5102         ENDIF
5103  100  CONTINUE
5104  101  CONTINUE
5105       YMAX = YMAX2
5106       YMIN = YMIN2
5107       XMAX = LOG(YMAX)
5108       XMIN = LOG(YMIN)
5109       XDEL = XMAX-XMIN
5110       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5111       DO 102 I=1,Max_tab
5112         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5113         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
5114         IF(Q2LOW2.GE.Q2MAX2) THEN
5115           WRITE(LO,'(/1X,A,2E12.4)')
5116      &      'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
5117           YMAX2 = MIN(Y1,YMAX2)
5118           GOTO 103
5119         ENDIF
5120  102  CONTINUE
5121  103  CONTINUE
5122       YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5123       IF(YMI.GT.YMIN1) THEN
5124         WRITE(LO,'(/1X,A,2E12.4)')
5125      &    'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
5126         YMIN1 = YMI
5127       ENDIF
5128       YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5129       IF(YMI.GT.YMIN2) THEN
5130         WRITE(LO,'(/1X,A,2E12.4)')
5131      &    'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
5132         YMIN2 = YMI
5133       ENDIF
5134 C
5135       X1MAX = LOG(YMAX1)
5136       X1MIN = LOG(YMIN1)
5137       X1DEL = X1MAX-X1MIN
5138       X2MAX = LOG(YMAX2)
5139       X2MIN = LOG(YMIN2)
5140       X2DEL = X2MAX-X2MIN
5141       DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
5142       FLUX = 0.D0
5143       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5144      &  'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
5145       DO 105 I=1,Max_tab
5146         Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
5147         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5148         FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
5149      &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
5150         FLUX = FLUX+Y1*FF
5151         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
5152  105  CONTINUE
5153       FLUX = FLUX*DELLY
5154       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5155      &  'PHO_GGHIOF: integrated flux (one side):',FLUX
5156 C
5157       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5158       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5159       Y1 = YMIN1
5160       Y2 = YMIN2
5161       WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
5162      &         -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5163      &       *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
5164      &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5165 C
5166 C  photon 1
5167       EGAM = YMAX1*EE
5168       P1(1) = 0.D0
5169       P1(2) = 0.D0
5170       P1(3) = EGAM
5171       P1(4) = EGAM
5172 C  photon 2
5173       EGAM = YMAX2*EE
5174       P2(1) = 0.D0
5175       P2(2) = 0.D0
5176       P2(3) = -EGAM
5177       P2(4) = EGAM
5178       CALL PHO_SETPAR(1,22,0,0.D0)
5179       CALL PHO_SETPAR(2,22,0,0.D0)
5180       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5181       CALL PHO_PHIST(-1,SIGMAX)
5182       CALL PHO_LHIST(-1,SIGMAX)
5183 C
5184 C  generation of events, flux calculation
5185
5186       ECFRAC = ECMIN**2/(4.D0*EE*EE)
5187       AY1  = 0.D0
5188       AY2  = 0.D0
5189       AYS1 = 0.D0
5190       AYS2 = 0.D0
5191       Q21MIN = 1.D30
5192       Q22MIN = 1.D30
5193       Q21MAX = 0.D0
5194       Q22MAX = 0.D0
5195       Q21AVE = 0.D0
5196       Q22AVE = 0.D0
5197       Q21AV2 = 0.D0
5198       Q22AV2 = 0.D0
5199       YY1MIN = 1.D30
5200       YY2MIN = 1.D30
5201       YY1MAX = 0.D0
5202       YY2MAX = 0.D0
5203       NITER = NEVENT
5204       ITRY = 0
5205       ITRW = 0
5206       DO 200 I=1,NITER
5207 C  sample y1, y2
5208  150    CONTINUE
5209         ITRY = ITRY+1
5210  175    CONTINUE
5211           ITRW = ITRW+1
5212           Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
5213           Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
5214           IF(Y1*Y2.LT.ECFRAC) GOTO 175
5215 C
5216           Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
5217           IF(Q2LOW1.GE.Q2MAX1) GOTO 175
5218           Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
5219           IF(Q2LOW2.GE.Q2MAX2) GOTO 175
5220           Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
5221           Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
5222           WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
5223      &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5224      &         *((1.D0+(1.D0-Y2)**2)*Q2LOG2
5225      &        -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5226           IF(WGMAX.LT.WGH) THEN
5227             WRITE(LO,'(1X,A,4E12.5)')
5228      &        'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
5229           ENDIF
5230         IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
5231 C  sample Q2
5232         IF(IPAMDL(174).EQ.1) THEN
5233           YEFF = 1.D0+(1.D0-Y1)**2
5234  185      CONTINUE
5235             Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
5236             WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
5237           IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
5238         ELSE
5239           Q2P1 = Q2LOW1
5240         ENDIF
5241         IF(IPAMDL(174).EQ.1) THEN
5242           YEFF = 1.D0+(1.D0-Y2)**2
5243  186      CONTINUE
5244             Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
5245             WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
5246           IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
5247         ELSE
5248           Q2P2 = Q2LOW2
5249         ENDIF
5250 C  impact parameter
5251         GAIMP(1) = 1.D0/SQRT(Q2P1)
5252         GAIMP(2) = 1.D0/SQRT(Q2P2)
5253 C  form factor (squared)
5254         FF21 = 1.D0
5255         IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
5256         FF22 = 1.D0
5257         IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
5258         IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
5259 C  do the hadrons overlap?
5260         IF(ISWMDL(26).GT.0) THEN
5261           DO 190 K=1,2
5262             CALL PHO_SFECFE(SIF,COF)
5263             BIMP(1,K) = SIF*GAIMP(K)
5264             BIMP(2,K) = COF*GAIMP(K)
5265  190      CONTINUE
5266           BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
5267      &                 +(BIMP(2,1)-BIMP(2,2))**2)
5268           IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
5269         ENDIF
5270 C  photon data
5271         GYY(1) = Y1
5272         GQ2(1) = Q2P1
5273         GYY(2) = Y2
5274         GQ2(2) = Q2P2
5275 C
5276
5277 C  incoming hadron 1
5278         PINI(1,1) = 0.D0
5279         PINI(2,1) = 0.D0
5280         PINI(3,1) = EE
5281         PINI(4,1) = EE
5282         PINI(5,1) = 0.D0
5283 C  outgoing hadron 1
5284         YQ2 = SQRT((1.D0-Y1)*Q2P1)
5285         Q2E = Q2P1/(4.D0*EE)
5286         E1Y = EE*(1.D0-Y1)
5287         CALL PHO_SFECFE(SIF,COF)
5288         PFIN(1,1) = YQ2*COF
5289         PFIN(2,1) = YQ2*SIF
5290         PFIN(3,1) = E1Y-Q2E
5291         PFIN(4,1) = E1Y+Q2E
5292         PFIN(5,1) = 0.D0
5293         PFPHI(1) = ATAN2(COF,SIF)
5294         PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
5295 C  photon 1
5296         P1(1) = -PFIN(1,1)
5297         P1(2) = -PFIN(2,1)
5298         P1(3) = PINI(3,1)-PFIN(3,1)
5299         P1(4) = PINI(4,1)-PFIN(4,1)
5300 C  incoming hadron 2
5301         PINI(1,2) = 0.D0
5302         PINI(2,2) = 0.D0
5303         PINI(3,2) = -EE
5304         PINI(4,2) = EE
5305         PINI(5,2) = 0.D0
5306 C  outgoing hadron 2
5307         YQ2 = SQRT((1.D0-Y2)*Q2P2)
5308         Q2E = Q2P2/(4.D0*EE)
5309         E1Y = EE*(1.D0-Y2)
5310         CALL PHO_SFECFE(SIF,COF)
5311         PFIN(1,2) = YQ2*COF
5312         PFIN(2,2) = YQ2*SIF
5313         PFIN(3,2) = -E1Y+Q2E
5314         PFIN(4,2) = E1Y+Q2E
5315         PFIN(5,2) = 0.D0
5316         PFPHI(2) = ATAN2(COF,SIF)
5317         PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
5318 C  photon 2
5319         P2(1) = -PFIN(1,2)
5320         P2(2) = -PFIN(2,2)
5321         P2(3) = PINI(3,2)-PFIN(3,2)
5322         P2(4) = PINI(4,2)-PFIN(4,2)
5323 C  ECMS cut
5324         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
5325      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
5326         IF(GGECM.LT.0.1D0) GOTO 175
5327         GGECM = SQRT(GGECM)
5328         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5329 C
5330         PGAM(1,1) = P1(1)
5331         PGAM(2,1) = P1(2)
5332         PGAM(3,1) = P1(3)
5333         PGAM(4,1) = P1(4)
5334         PGAM(5,1) = -SQRT(Q2P1)
5335         PGAM(1,2) = P2(1)
5336         PGAM(2,2) = P2(2)
5337         PGAM(3,2) = P2(3)
5338         PGAM(4,2) = P2(4)
5339         PGAM(5,2) = -SQRT(Q2P2)
5340 C  photon helicities
5341         IGHEL(1) = 1
5342         IGHEL(2) = 1
5343 C  cut given by user
5344         CALL PHO_PRESEL(5,IREJ)
5345         IF(IREJ.NE.0) GOTO 175
5346 C  event generation
5347         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5348         IF(IREJ.NE.0) GOTO 150
5349
5350 C  statistics
5351         AY1  = AY1+Y1
5352         AYS1 = AYS1+Y1*Y1
5353         AY2  = AY2+Y2
5354         AYS2 = AYS2+Y2*Y2
5355         Q21MIN = MIN(Q21MIN,Q2P1)
5356         Q22MIN = MIN(Q22MIN,Q2P2)
5357         Q21MAX = MAX(Q21MAX,Q2P1)
5358         Q22MAX = MAX(Q22MAX,Q2P2)
5359         YY1MIN = MIN(YY1MIN,Y1)
5360         YY2MIN = MIN(YY2MIN,Y2)
5361         YY1MAX = MAX(YY1MAX,Y1)
5362         YY2MAX = MAX(YY2MAX,Y2)
5363         Q21AVE = Q21AVE+Q2P1
5364         Q22AVE = Q22AVE+Q2P2
5365         Q21AV2 = Q21AV2+Q2P1*Q2P1
5366         Q22AV2 = Q22AV2+Q2P2*Q2P2
5367 C  histograms
5368         CALL PHO_PHIST(1,HSWGHT(0))
5369         CALL PHO_LHIST(1,HSWGHT(0))
5370  200  CONTINUE
5371 C
5372       WGY  = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
5373       WGY  = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
5374       AY1  = AY1/DBLE(NITER)
5375       AYS1 = AYS1/DBLE(NITER)
5376       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5377       AY2  = AY2/DBLE(NITER)
5378       AYS2 = AYS2/DBLE(NITER)
5379       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5380       Q21AVE = Q21AVE/DBLE(NITER)
5381       Q21AV2 = Q21AV2/DBLE(NITER)
5382       Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
5383       Q22AVE = Q22AVE/DBLE(NITER)
5384       Q22AV2 = Q22AV2/DBLE(NITER)
5385       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
5386       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5387 C  output of statistics, histograms
5388       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5389      &'=========================================================',
5390      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
5391      &'========================================================='
5392       WRITE(LO,'(//1X,A,3I10)')
5393      &  'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5394       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5395      &  WGY,WEIGHT
5396       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
5397      &  AY1,DAY1
5398       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
5399      &  AY2,DAY2
5400       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
5401      &  YY1MIN,YY1MAX
5402       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
5403      &  YY2MIN,YY2MAX
5404       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1      ',
5405      &  Q21AVE,Q21AV2
5406       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1    ',
5407      &  Q21MIN,Q21MAX
5408       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
5409      &  Q22AVE,Q22AV2
5410       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
5411      &  Q22MIN,Q22MAX
5412 C
5413       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5414       IF(NITER.GT.1) THEN
5415         CALL PHO_PHIST(-2,WEIGHT)
5416         CALL PHO_LHIST(-2,WEIGHT)
5417       ELSE
5418         WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
5419       ENDIF
5420
5421       END
5422
5423 CDECK  ID>, PHO_GGHIOG
5424       SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
5425 C**********************************************************************
5426 C
5427 C     interface to call PHOJET (variable energy run) for
5428 C     gamma-gamma collisions via heavy ions (geometrical approach)
5429 C
5430 C
5431 C     input:     EEN     LAB system energy per nucleon
5432 C                NA      atomic number of ion/hadron
5433 C                NZ      charge number of ion/hadron
5434 C                NEVENT  number of events to generate
5435 C            from /LEPCUT/:
5436 C                YMIN1,2 lower limit of Y
5437 C                        (energy fraction taken by photon from hadron)
5438 C                YMAX1,2 upper cutoff for Y, necessary to avoid
5439 C                        underflows
5440 C
5441 C      currently implemented approximation similar to:
5442 C
5443 C
5444 C**********************************************************************
5445       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5446       SAVE
5447
5448       PARAMETER ( DEPS = 1.D-20,
5449      &            PI   = 3.14159265359D0 )
5450
5451 C  input/output channels
5452       INTEGER LI,LO
5453       COMMON /POINOU/ LI,LO
5454 C  event debugging information
5455       INTEGER NMAXD
5456       PARAMETER (NMAXD=100)
5457       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
5458      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5459       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5460      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5461 C  photon flux kinematics and cuts
5462       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5463      &                 YMIN1,YMAX1,YMIN2,YMAX2,
5464      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5465      &                 THMIN1,THMAX1,THMIN2,THMAX2
5466       INTEGER          ITAG1,ITAG2
5467       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5468      &                YMIN1,YMAX1,YMIN2,YMAX2,
5469      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5470      &                THMIN1,THMAX1,THMIN2,THMAX2,
5471      &                ITAG1,ITAG2
5472 C  gamma-lepton or gamma-hadron vertex information
5473       INTEGER IGHEL,IDPSRC,IDBSRC
5474       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5475      &                 RADSRC,AMSRC,GAMSRC
5476       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5477      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5478      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5479 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
5480       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5481       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5482       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5483      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5484 C  event weights and generated cross section
5485       INTEGER IPOWGC,ISWCUT,IVWGHT
5486       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5487       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5488      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5489
5490       PARAMETER (Max_tab=100)
5491       DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
5492
5493 C
5494       WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
5495      &                      '---------------------------------------'
5496 C  hadron size and mass
5497       FM2GEV = 5.07D0
5498       HIMASS = DBLE(NA)*0.938D0
5499       HIMA2  = HIMASS**2
5500       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5501       ALPHA  = DBLE(NZ**2)/137.D0
5502 C  total hadron / heavy ion energy
5503       EE     = EEN*DBLE(NA)
5504       GAMMA  = EE/HIMASS
5505 C  setup /POFSRC/
5506       GAMSRC(1) = GAMMA
5507       GAMSRC(2) = GAMMA
5508       RADSRC(1) = HIRADI
5509       RADSRC(2) = HIRADI
5510       AMSRC(1)  = HIMASS
5511       AMSRC(1)  = HIMASS
5512 C  kinematic limitations
5513       YMI = (ECMIN/(2.D0*EE))**2
5514       IF(YMIN1.LT.YMI) THEN
5515         WRITE(LO,'(/1X,A,2E12.5)')
5516      &    'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
5517         YMIN1 = YMI
5518       ELSE IF(YMIN1.GT.YMI) THEN
5519         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5520      &    'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5521      &    '  INSTEAD OF',YMIN1
5522       ENDIF
5523       IF(YMIN2.LT.YMI) THEN
5524         WRITE(LO,'(/1X,A,2E12.5)')
5525      &    'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
5526         YMIN2 = YMI
5527       ELSE IF(YMIN2.GT.YMI) THEN
5528         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5529      &    'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5530      &    '  INSTEAD OF',YMIN2
5531       ENDIF
5532 C  debug output
5533       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
5534       WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
5535       WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
5536       WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA               ',GAMMA
5537       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
5538      &  YMAX1
5539       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
5540      &  YMAX2
5541       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
5542      &  2.D0*EEN,2.D0*EE
5543       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
5544 C  hadron numbers set to 0
5545       IDPSRC(1) = 0
5546       IDBSRC(1) = 0
5547       IDPSRC(2) = 0
5548       IDBSRC(2) = 0
5549 C  table of flux function, log interpolation
5550       YMIN = YMIN1
5551       YMAX = YMAX1
5552       YMAX = MIN(YMAX,0.9999999D0)
5553       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5554       TABYL(0) = LOG(YMIN)
5555       FFMAX = 0.D0
5556       DO 100 I=1,Max_tab
5557         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5558         WG = EE*Y
5559         XI = WG*HIRADI/GAMMA
5560         FF = ALPHA*PHO_GGFLCL(XI)/Y
5561         FFMAX = MAX(FF,FFMAX)
5562         IF(FF.LT.1.D-10*FFMAX) THEN
5563           WRITE(LO,'(/1X,A,2E12.4)')
5564      &      'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
5565           YMAX1 = MIN(Y,YMAX1)
5566           GOTO 101
5567         ENDIF
5568  100  CONTINUE
5569  101  CONTINUE
5570       YMIN = YMIN2
5571       YMAX = YMAX2
5572       YMAX = MIN(YMAX,0.9999999D0)
5573       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5574       TABYL(0) = LOG(YMIN)
5575       FFMAX = 0.D0
5576       DO 102 I=1,Max_tab
5577         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5578         WG = EE*Y
5579         XI = WG*HIRADI/GAMMA
5580         FF = ALPHA*PHO_GGFLCL(XI)/Y
5581         FFMAX = MAX(FF,FFMAX)
5582         IF(FF.LT.1.D-10*FFMAX) THEN
5583           WRITE(LO,'(/1X,A,2E12.4)')
5584      &      'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
5585           YMAX2 = MIN(Y,YMAX2)
5586           GOTO 103
5587         ENDIF
5588  102  CONTINUE
5589  103  CONTINUE
5590       YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5591       IF(YMI.GT.YMIN1) THEN
5592         WRITE(LO,'(/1X,A,2E12.4)')
5593      &    'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
5594         YMIN1 = YMI
5595       ENDIF
5596       YMAX1 = MIN(YMAX,YMAX1)
5597       YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5598       IF(YMI.GT.YMIN2) THEN
5599         WRITE(LO,'(/1X,A,2E12.4)')
5600      &    'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
5601         YMIN2 = YMI
5602       ENDIF
5603 C
5604       YMIN = YMIN1
5605       YMAX = YMAX1
5606       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5607       TABCU(0) = 0.D0
5608       TABYL(0) = LOG(YMIN)
5609       FLUX = 0.D0
5610       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5611      &  'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
5612       DO 105 I=1,Max_tab
5613         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5614         WG = EE*Y
5615         XI = WG*HIRADI/GAMMA
5616         FF = ALPHA*PHO_GGFLCL(XI)/Y
5617         FFMAX = MAX(FF,FFMAX)
5618         TABCU(I) = TABCU(I-1)+FF*Y
5619         TABYL(I) = LOG(Y)
5620         FLUX = FLUX+Y*FF
5621         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
5622  105  CONTINUE
5623       FLUX = FLUX*DELLY
5624       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5625      &  'PHO_GGHIOG: integrated flux (one side):',FLUX
5626 C
5627 C  initialization
5628 C  photon 1
5629       EGAM = YMAX*EE
5630       P1(1) = 0.D0
5631       P1(2) = 0.D0
5632       P1(3) = EGAM
5633       P1(4) = EGAM
5634 C  photon 2
5635       EGAM = YMAX*EE
5636       P2(1) = 0.D0
5637       P2(2) = 0.D0
5638       P2(3) = -EGAM
5639       P2(4) = EGAM
5640       CALL PHO_SETPAR(1,22,0,0.D0)
5641       CALL PHO_SETPAR(2,22,0,0.D0)
5642       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5643       CALL PHO_PHIST(-1,SIGMAX)
5644       CALL PHO_LHIST(-1,SIGMAX)
5645 C
5646 C  generation of events
5647
5648       AY1  = 0.D0
5649       AY2  = 0.D0
5650       AYS1 = 0.D0
5651       AYS2 = 0.D0
5652       YY1MIN = 1.D30
5653       YY2MIN = 1.D30
5654       YY1MAX = 0.D0
5655       YY2MAX = 0.D0
5656       NITER = NEVENT
5657       ITRY = 0
5658       ITRW = 0
5659       DO 200 I=1,NITER
5660  150    CONTINUE
5661         ITRY = ITRY+1
5662  175    CONTINUE
5663         ITRW = ITRW+1
5664         XI = DT_RNDM(AY1)*TABCU(Max_tab)
5665         DO 110 K=1,Max_tab
5666           IF(TABCU(K).GE.XI) THEN
5667             Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5668             Y1 = EXP(Y1)
5669             GOTO 120
5670           ENDIF
5671  110    CONTINUE
5672         Y1 = YMAX1
5673  120    CONTINUE
5674         XI = DT_RNDM(AY2)*TABCU(Max_tab)
5675         DO 130 K=1,Max_tab
5676           IF(TABCU(K).GE.XI) THEN
5677             Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5678             Y2 = EXP(Y2)
5679             GOTO 140
5680           ENDIF
5681  130    CONTINUE
5682         Y2 = YMAX2
5683  140    CONTINUE
5684 C  setup kinematics
5685
5686         GYY(1) = Y1
5687         GQ2(1) = 0.D0
5688         GYY(2) = Y2
5689         GQ2(2) = 0.D0
5690 C  incoming electron 1
5691         PINI(1,1) = 0.D0
5692         PINI(2,1) = 0.D0
5693         PINI(3,1) = EE
5694         PINI(4,1) = EE
5695         PINI(5,1) = 0.D0
5696 C  outgoing electron 1
5697         E1Y = EE*(1.D0-Y1)
5698         PFIN(1,1) = 0.D0
5699         PFIN(2,1) = 0.D0
5700         PFIN(3,1) = E1Y
5701         PFIN(4,1) = E1Y
5702         PFIN(5,1) = 0.D0
5703 C  photon 1
5704         P1(1) = -PFIN(1,1)
5705         P1(2) = -PFIN(2,1)
5706         P1(3) = PINI(3,1)-PFIN(3,1)
5707         P1(4) = PINI(4,1)-PFIN(4,1)
5708 C  incoming electron 2
5709         PINI(1,2) = 0.D0
5710         PINI(2,2) = 0.D0
5711         PINI(3,2) = -EE
5712         PINI(4,2) = EE
5713         PINI(5,2) = 0.D0
5714 C  outgoing electron 2
5715         E1Y = EE*(1.D0-Y2)
5716         PFIN(1,2) = 0.D0
5717         PFIN(2,2) = 0.D0
5718         PFIN(3,2) = -E1Y
5719         PFIN(4,2) = E1Y
5720         PFIN(5,2) = 0.D0
5721 C  photon 2
5722         P2(1) = -PFIN(1,2)
5723         P2(2) = -PFIN(2,2)
5724         P2(3) = PINI(3,2)-PFIN(3,2)
5725         P2(4) = PINI(4,2)-PFIN(4,2)
5726 C  ECMS cut
5727         GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
5728         IF(GGECM.LT.0.1D0) GOTO 175
5729         GGECM = SQRT(GGECM)
5730         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5731         PGAM(1,1) = P1(1)
5732         PGAM(2,1) = P1(2)
5733         PGAM(3,1) = P1(3)
5734         PGAM(4,1) = P1(4)
5735         PGAM(5,1) = 0.D0
5736         PGAM(1,2) = P2(1)
5737         PGAM(2,2) = P2(2)
5738         PGAM(3,2) = P2(3)
5739         PGAM(4,2) = P2(4)
5740         PGAM(5,2) = 0.D0
5741 C  impact parameter constraints
5742         XI1   = P1(4)*HIRADI/GAMMA
5743         XI2   = P2(4)*HIRADI/GAMMA
5744         FLX   = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
5745         FCORR = PHO_GGFLCR(HIRADI)
5746         WGX   = (FLX-FCORR)/FLX
5747         IF(DT_RNDM(Y2).GT.WGX) GOTO 175
5748 C  photon helicities
5749         IGHEL(1) = 1
5750         IGHEL(2) = 1
5751 C  cut given by user
5752         CALL PHO_PRESEL(5,IREJ)
5753         IF(IREJ.NE.0) GOTO 175
5754 C  event generation
5755         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5756         IF(IREJ.NE.0) GOTO 150
5757
5758 C  statistics
5759         AY1  = AY1+Y1
5760         AYS1 = AYS1+Y1*Y1
5761         AY2  = AY2+Y2
5762         AYS2 = AYS2+Y2*Y2
5763         YY1MIN = MIN(YY1MIN,Y1)
5764         YY2MIN = MIN(YY2MIN,Y2)
5765         YY1MAX = MAX(YY1MAX,Y1)
5766         YY2MAX = MAX(YY2MAX,Y2)
5767 C  histograms
5768         CALL PHO_PHIST(1,HSWGHT(0))
5769         CALL PHO_LHIST(1,HSWGHT(0))
5770  200  CONTINUE
5771 C
5772       WGY  = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
5773       AY1  = AY1/DBLE(NITER)
5774       AYS1 = AYS1/DBLE(NITER)
5775       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5776       AY2  = AY2/DBLE(NITER)
5777       AYS2 = AYS2/DBLE(NITER)
5778       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5779       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5780 C  output of statistics, histograms
5781       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5782      &'=========================================================',
5783      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
5784      &'========================================================='
5785       WRITE(LO,'(//1X,A,3I12)')
5786      &  'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5787       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5788      &  WGY,WEIGHT
5789       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
5790      &  AY1,DAY1
5791       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
5792      &  AY2,DAY2
5793       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
5794      &  YY1MIN,YY1MAX
5795       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
5796      &  YY2MIN,YY2MAX
5797
5798 C
5799       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5800       IF(NITER.GT.1) THEN
5801         CALL PHO_PHIST(-2,WEIGHT)
5802         CALL PHO_LHIST(-2,WEIGHT)
5803       ELSE
5804         WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
5805       ENDIF
5806
5807       END
5808
5809 CDECK  ID>, PHO_GGFLCL
5810       DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
5811 C*********************************************************************
5812 C
5813 C     semi-classical photon flux (geometrical model)
5814 C
5815 C*********************************************************************
5816       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5817       SAVE
5818
5819       PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
5820      &  -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
5821
5822       END
5823
5824 CDECK  ID>, PHO_GGFLCR
5825       DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
5826 C*********************************************************************
5827 C
5828 C     semi-classical photon flux correction due to
5829 C     overlap in impact parameter space (geometrical model)
5830 C
5831 C*********************************************************************
5832       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5833       SAVE
5834
5835       PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
5836
5837 C  input/output channels
5838       INTEGER LI,LO
5839       COMMON /POINOU/ LI,LO
5840 C  gamma-lepton or gamma-hadron vertex information
5841       INTEGER IGHEL,IDPSRC,IDBSRC
5842       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5843      &                 RADSRC,AMSRC,GAMSRC
5844       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5845      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5846      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5847
5848       DIMENSION XGAUSS(126),WGAUSS(126)
5849
5850       DATA XGAUSS(1)/ .57735026918962576D0/
5851       DATA XGAUSS(2)/-.57735026918962576D0/
5852       DATA WGAUSS(1)/ 1.00000000000000000D0/
5853       DATA WGAUSS(2)/ 1.00000000000000000D0/
5854
5855       DATA XGAUSS(3)/ .33998104358485627D0/
5856       DATA XGAUSS(4)/ .86113631159405258D0/
5857       DATA XGAUSS(5)/-.33998104358485627D0/
5858       DATA XGAUSS(6)/-.86113631159405258D0/
5859       DATA WGAUSS(3)/ .65214515486254613D0/
5860       DATA WGAUSS(4)/ .34785484513745385D0/
5861       DATA WGAUSS(5)/ .65214515486254613D0/
5862       DATA WGAUSS(6)/ .34785484513745385D0/
5863
5864       DATA XGAUSS(7)/ .18343464249564981D0/
5865       DATA XGAUSS(8)/ .52553240991632899D0/
5866       DATA XGAUSS(9)/ .79666647741362674D0/
5867       DATA XGAUSS(10)/ .96028985649753623D0/
5868       DATA XGAUSS(11)/-.18343464249564981D0/
5869       DATA XGAUSS(12)/-.52553240991632899D0/
5870       DATA XGAUSS(13)/-.79666647741362674D0/
5871       DATA XGAUSS(14)/-.96028985649753623D0/
5872       DATA WGAUSS(7)/ .36268378337836198D0/
5873       DATA WGAUSS(8)/ .31370664587788727D0/
5874       DATA WGAUSS(9)/ .22238103445337448D0/
5875       DATA WGAUSS(10)/ .10122853629037627D0/
5876       DATA WGAUSS(11)/ .36268378337836198D0/
5877       DATA WGAUSS(12)/ .31370664587788727D0/
5878       DATA WGAUSS(13)/ .22238103445337448D0/
5879       DATA WGAUSS(14)/ .10122853629037627D0/
5880
5881       DATA XGAUSS(15)/ .0950125098376374402D0/
5882       DATA XGAUSS(16)/ .281603550779258913D0/
5883       DATA XGAUSS(17)/ .458016777657227386D0/
5884       DATA XGAUSS(18)/ .617876244402643748D0/
5885       DATA XGAUSS(19)/ .755404408355003034D0/
5886       DATA XGAUSS(20)/ .865631202387831744D0/
5887       DATA XGAUSS(21)/ .944575023073232576D0/
5888       DATA XGAUSS(22)/ .989400934991649933D0/
5889       DATA XGAUSS(23)/-.0950125098376374402D0/
5890       DATA XGAUSS(24)/-.281603550779258913D0/
5891       DATA XGAUSS(25)/-.458016777657227386D0/
5892       DATA XGAUSS(26)/-.617876244402643748D0/
5893       DATA XGAUSS(27)/-.755404408355003034D0/
5894       DATA XGAUSS(28)/-.865631202387831744D0/
5895       DATA XGAUSS(29)/-.944575023073232576D0/
5896       DATA XGAUSS(30)/-.989400934991649933D0/
5897       DATA WGAUSS(15)/ .189450610455068496D0/
5898       DATA WGAUSS(16)/ .182603415044923589D0/
5899       DATA WGAUSS(17)/ .169156519395002538D0/
5900       DATA WGAUSS(18)/ .149595988816576732D0/
5901       DATA WGAUSS(19)/ .124628971255533872D0/
5902       DATA WGAUSS(20)/ .0951585116824927848D0/
5903       DATA WGAUSS(21)/ .0622535239386478929D0/
5904       DATA WGAUSS(22)/ .0271524594117540949D0/
5905       DATA WGAUSS(23)/ .189450610455068496D0/
5906       DATA WGAUSS(24)/ .182603415044923589D0/
5907       DATA WGAUSS(25)/ .169156519395002538D0/
5908       DATA WGAUSS(26)/ .149595988816576732D0/
5909       DATA WGAUSS(27)/ .124628971255533872D0/
5910       DATA WGAUSS(28)/ .0951585116824927848D0/
5911       DATA WGAUSS(29)/ .0622535239386478929D0/
5912       DATA WGAUSS(30)/ .0271524594117540949D0/
5913
5914       DATA XGAUSS(31)/ .0483076656877383162D0/
5915       DATA XGAUSS(32)/ .144471961582796493D0/
5916       DATA XGAUSS(33)/ .239287362252137075D0/
5917       DATA XGAUSS(34)/ .331868602282127650D0/
5918       DATA XGAUSS(35)/ .421351276130635345D0/
5919       DATA XGAUSS(36)/ .506899908932229390D0/
5920       DATA XGAUSS(37)/ .587715757240762329D0/
5921       DATA XGAUSS(38)/ .663044266930215201D0/
5922       DATA XGAUSS(39)/ .732182118740289680D0/
5923       DATA XGAUSS(40)/ .794483795967942407D0/
5924       DATA XGAUSS(41)/ .849367613732569970D0/
5925       DATA XGAUSS(42)/ .896321155766052124D0/
5926       DATA XGAUSS(43)/ .934906075937739689D0/
5927       DATA XGAUSS(44)/ .964762255587506430D0/
5928       DATA XGAUSS(45)/ .985611511545268335D0/
5929       DATA XGAUSS(46)/ .997263861849481564D0/
5930       DATA XGAUSS(47)/-.0483076656877383162D0/
5931       DATA XGAUSS(48)/-.144471961582796493D0/
5932       DATA XGAUSS(49)/-.239287362252137075D0/
5933       DATA XGAUSS(50)/-.331868602282127650D0/
5934       DATA XGAUSS(51)/-.421351276130635345D0/
5935       DATA XGAUSS(52)/-.506899908932229390D0/
5936       DATA XGAUSS(53)/-.587715757240762329D0/
5937       DATA XGAUSS(54)/-.663044266930215201D0/
5938       DATA XGAUSS(55)/-.732182118740289680D0/
5939       DATA XGAUSS(56)/-.794483795967942407D0/
5940       DATA XGAUSS(57)/-.849367613732569970D0/
5941       DATA XGAUSS(58)/-.896321155766052124D0/
5942       DATA XGAUSS(59)/-.934906075937739689D0/
5943       DATA XGAUSS(60)/-.964762255587506430D0/
5944       DATA XGAUSS(61)/-.985611511545268335D0/
5945       DATA XGAUSS(62)/-.997263861849481564D0/
5946       DATA WGAUSS(31)/ .0965400885147278006D0/
5947       DATA WGAUSS(32)/ .0956387200792748594D0/
5948       DATA WGAUSS(33)/ .0938443990808045654D0/
5949       DATA WGAUSS(34)/ .0911738786957638847D0/
5950       DATA WGAUSS(35)/ .0876520930044038111D0/
5951       DATA WGAUSS(36)/ .0833119242269467552D0/
5952       DATA WGAUSS(37)/ .0781938957870703065D0/
5953       DATA WGAUSS(38)/ .0723457941088485062D0/
5954       DATA WGAUSS(39)/ .0658222227763618468D0/
5955       DATA WGAUSS(40)/ .0586840934785355471D0/
5956       DATA WGAUSS(41)/ .0509980592623761762D0/
5957       DATA WGAUSS(42)/ .0428358980222266807D0/
5958       DATA WGAUSS(43)/ .0342738629130214331D0/
5959       DATA WGAUSS(44)/ .0253920653092620595D0/
5960       DATA WGAUSS(45)/ .0162743947309056706D0/
5961       DATA WGAUSS(46)/ .00701861000947009660D0/
5962       DATA WGAUSS(47)/ .0965400885147278006D0/
5963       DATA WGAUSS(48)/ .0956387200792748594D0/
5964       DATA WGAUSS(49)/ .0938443990808045654D0/
5965       DATA WGAUSS(50)/ .0911738786957638847D0/
5966       DATA WGAUSS(51)/ .0876520930044038111D0/
5967       DATA WGAUSS(52)/ .0833119242269467552D0/
5968       DATA WGAUSS(53)/ .0781938957870703065D0/
5969       DATA WGAUSS(54)/ .0723457941088485062D0/
5970       DATA WGAUSS(55)/ .0658222227763618468D0/
5971       DATA WGAUSS(56)/ .0586840934785355471D0/
5972       DATA WGAUSS(57)/ .0509980592623761762D0/
5973       DATA WGAUSS(58)/ .0428358980222266807D0/
5974       DATA WGAUSS(59)/ .0342738629130214331D0/
5975       DATA WGAUSS(60)/ .0253920653092620595D0/
5976       DATA WGAUSS(61)/ .0162743947309056706D0/
5977       DATA WGAUSS(62)/ .00701861000947009660D0/
5978
5979       DATA XGAUSS(63)/ .02435029266342443250D0/
5980       DATA XGAUSS(64)/ .0729931217877990394D0/
5981       DATA XGAUSS(65)/ .121462819296120554D0/
5982       DATA XGAUSS(66)/ .169644420423992818D0/
5983       DATA XGAUSS(67)/ .217423643740007084D0/
5984       DATA XGAUSS(68)/ .264687162208767416D0/
5985       DATA XGAUSS(69)/ .311322871990210956D0/
5986       DATA XGAUSS(70)/ .357220158337668116D0/
5987       DATA XGAUSS(71)/ .402270157963991604D0/
5988       DATA XGAUSS(72)/ .446366017253464088D0/
5989       DATA XGAUSS(73)/ .489403145707052957D0/
5990       DATA XGAUSS(74)/ .531279464019894546D0/
5991       DATA XGAUSS(75)/ .571895646202634034D0/
5992       DATA XGAUSS(76)/ .611155355172393250D0/
5993       DATA XGAUSS(77)/ .648965471254657340D0/
5994       DATA XGAUSS(78)/ .685236313054233243D0/
5995       DATA XGAUSS(79)/ .719881850171610827D0/
5996       DATA XGAUSS(80)/ .752819907260531897D0/
5997       DATA XGAUSS(81)/ .783972358943341408D0/
5998       DATA XGAUSS(82)/ .813265315122797560D0/
5999       DATA XGAUSS(83)/ .840629296252580363D0/
6000       DATA XGAUSS(84)/ .865999398154092820D0/
6001       DATA XGAUSS(85)/ .889315445995114106D0/
6002       DATA XGAUSS(86)/ .910522137078502806D0/
6003       DATA XGAUSS(87)/ .929569172131939576D0/
6004       DATA XGAUSS(88)/ .946411374858402816D0/
6005       DATA XGAUSS(89)/ .961008799652053719D0/
6006       DATA XGAUSS(90)/ .973326827789910964D0/
6007       DATA XGAUSS(91)/ .983336253884625957D0/
6008       DATA XGAUSS(92)/ .991013371476744321D0/
6009       DATA XGAUSS(93)/ .996340116771955279D0/
6010       DATA XGAUSS(94)/ .999305041735772139D0/
6011       DATA XGAUSS(95)/-.02435029266342443250D0/
6012       DATA XGAUSS(96)/-.0729931217877990394D0/
6013       DATA XGAUSS(97)/-.121462819296120554D0/
6014       DATA XGAUSS(98)/-.169644420423992818D0/
6015       DATA XGAUSS(99)/-.217423643740007084D0/
6016       DATA XGAUSS(100)/-.264687162208767416D0/
6017       DATA XGAUSS(101)/-.311322871990210956D0/
6018       DATA XGAUSS(102)/-.357220158337668116D0/
6019       DATA XGAUSS(103)/-.402270157963991604D0/
6020       DATA XGAUSS(104)/-.446366017253464088D0/
6021       DATA XGAUSS(105)/-.489403145707052957D0/
6022       DATA XGAUSS(106)/-.531279464019894546D0/
6023       DATA XGAUSS(107)/-.571895646202634034D0/
6024       DATA XGAUSS(108)/-.611155355172393250D0/
6025       DATA XGAUSS(109)/-.648965471254657340D0/
6026       DATA XGAUSS(110)/-.685236313054233243D0/
6027       DATA XGAUSS(111)/-.719881850171610827D0/
6028       DATA XGAUSS(112)/-.752819907260531897D0/
6029       DATA XGAUSS(113)/-.783972358943341408D0/
6030       DATA XGAUSS(114)/-.813265315122797560D0/
6031       DATA XGAUSS(115)/-.840629296252580363D0/
6032       DATA XGAUSS(116)/-.865999398154092820D0/
6033       DATA XGAUSS(117)/-.889315445995114106D0/
6034       DATA XGAUSS(118)/-.910522137078502806D0/
6035       DATA XGAUSS(119)/-.929569172131939576D0/
6036       DATA XGAUSS(120)/-.946411374858402816D0/
6037       DATA XGAUSS(121)/-.961008799652053719D0/
6038       DATA XGAUSS(122)/-.973326827789910964D0/
6039       DATA XGAUSS(123)/-.983336253884625957D0/
6040       DATA XGAUSS(124)/-.991013371476744321D0/
6041       DATA XGAUSS(125)/-.996340116771955279D0/
6042       DATA XGAUSS(126)/-.999305041735772139D0/
6043       DATA WGAUSS(63)/ .0486909570091397204D0/
6044       DATA WGAUSS(64)/ .0485754674415034269D0/
6045       DATA WGAUSS(65)/ .0483447622348029572D0/
6046       DATA WGAUSS(66)/ .0479993885964583077D0/
6047       DATA WGAUSS(67)/ .0475401657148303087D0/
6048       DATA WGAUSS(68)/ .0469681828162100173D0/
6049       DATA WGAUSS(69)/ .0462847965813144172D0/
6050       DATA WGAUSS(70)/ .0454916279274181445D0/
6051       DATA WGAUSS(71)/ .0445905581637565631D0/
6052       DATA WGAUSS(72)/ .0435837245293234534D0/
6053       DATA WGAUSS(73)/ .0424735151236535890D0/
6054       DATA WGAUSS(74)/ .0412625632426235286D0/
6055       DATA WGAUSS(75)/ .0399537411327203414D0/
6056       DATA WGAUSS(76)/ .0385501531786156291D0/
6057       DATA WGAUSS(77)/ .0370551285402400460D0/
6058       DATA WGAUSS(78)/ .0354722132568823838D0/
6059       DATA WGAUSS(79)/ .0338051618371416094D0/
6060       DATA WGAUSS(80)/ .0320579283548515535D0/
6061       DATA WGAUSS(81)/ .0302346570724024789D0/
6062       DATA WGAUSS(82)/ .0283396726142594832D0/
6063       DATA WGAUSS(83)/ .0263774697150546587D0/
6064       DATA WGAUSS(84)/ .0243527025687108733D0/
6065       DATA WGAUSS(85)/ .0222701738083832542D0/
6066       DATA WGAUSS(86)/ .0201348231535302094D0/
6067       DATA WGAUSS(87)/ .0179517157756973431D0/
6068       DATA WGAUSS(88)/ .0157260304760247193D0/
6069       DATA WGAUSS(89)/ .0134630478967186426D0/
6070       DATA WGAUSS(90)/ .0111681394601311288D0/
6071       DATA WGAUSS(91)/ .00884675982636394772D0/
6072       DATA WGAUSS(92)/ .00650445796897836286D0/
6073       DATA WGAUSS(93)/ .00414703326056246764D0/
6074       DATA WGAUSS(94)/ .00178328072169643295D0/
6075       DATA WGAUSS(95)/ .0486909570091397204D0/
6076       DATA WGAUSS(96)/ .0485754674415034269D0/
6077       DATA WGAUSS(97)/ .0483447622348029572D0/
6078       DATA WGAUSS(98)/ .0479993885964583077D0/
6079       DATA WGAUSS(99)/ .0475401657148303087D0/
6080       DATA WGAUSS(100)/ .0469681828162100173D0/
6081       DATA WGAUSS(101)/ .0462847965813144172D0/
6082       DATA WGAUSS(102)/ .0454916279274181445D0/
6083       DATA WGAUSS(103)/ .0445905581637565631D0/
6084       DATA WGAUSS(104)/ .0435837245293234534D0/
6085       DATA WGAUSS(105)/ .0424735151236535890D0/
6086       DATA WGAUSS(106)/ .0412625632426235286D0/
6087       DATA WGAUSS(107)/ .0399537411327203414D0/
6088       DATA WGAUSS(108)/ .0385501531786156291D0/
6089       DATA WGAUSS(109)/ .0370551285402400460D0/
6090       DATA WGAUSS(110)/ .0354722132568823838D0/
6091       DATA WGAUSS(111)/ .0338051618371416094D0/
6092       DATA WGAUSS(112)/ .0320579283548515535D0/
6093       DATA WGAUSS(113)/ .0302346570724024789D0/
6094       DATA WGAUSS(114)/ .0283396726142594832D0/
6095       DATA WGAUSS(115)/ .0263774697150546587D0/
6096       DATA WGAUSS(116)/ .0243527025687108733D0/
6097       DATA WGAUSS(117)/ .0222701738083832542D0/
6098       DATA WGAUSS(118)/ .0201348231535302094D0/
6099       DATA WGAUSS(119)/ .0179517157756973431D0/
6100       DATA WGAUSS(120)/ .0157260304760247193D0/
6101       DATA WGAUSS(121)/ .0134630478967186426D0/
6102       DATA WGAUSS(122)/ .0111681394601311288D0/
6103       DATA WGAUSS(123)/ .00884675982636394772D0/
6104       DATA WGAUSS(124)/ .00650445796897836286D0/
6105       DATA WGAUSS(125)/ .00414703326056246764D0/
6106       DATA WGAUSS(126)/ .00178328072169643295D0/
6107
6108 C integrate first over b1
6109 C
6110 C Loop incrementing the boundary
6111 C
6112       tmin = 0.D0
6113       tmax = 0.25D0
6114       Sum  = 0.D0
6115
6116  50   CONTINUE
6117
6118 C
6119 C Loop for the Gauss integration
6120 C
6121       XINT=0.D0
6122       DO 100 N=1,6
6123         XINT2 = XINT
6124         XINT=0.D0
6125         DO 200 I=2**N-1,2**(N+1)-2
6126           t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
6127           b1 = RADSRC(1) * EXP (t)
6128           XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
6129  200    CONTINUE
6130         XINT = (tmax-tmin)/2.D0*XINT
6131         IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
6132  100  CONTINUE
6133         WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
6134  300  CONTINUE
6135
6136       Sum = Sum + XINT
6137       IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
6138         tmin = tmax
6139         tmax = tmax + 0.5D0
6140         GOTO 50
6141       ENDIF
6142
6143       PHO_GGFLCR = 4.D0*Pi * Sum
6144
6145       END
6146
6147 CDECK  ID>, PHO_GGFAUX
6148       DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
6149 C*********************************************************************
6150 C
6151 C     auxiliary function for integration over b2,
6152 C     semi-classical photon flux correction due to
6153 C     overlap in impact parameter space (geometrical model)
6154 C
6155 C*********************************************************************
6156       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6157       SAVE
6158
6159       PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
6160
6161 C  input/output channels
6162       INTEGER LI,LO
6163       COMMON /POINOU/ LI,LO
6164 C  gamma-lepton or gamma-hadron vertex information
6165       INTEGER IGHEL,IDPSRC,IDBSRC
6166       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6167      &                 RADSRC,AMSRC,GAMSRC
6168       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6169      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6170      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6171
6172       DIMENSION XGAUSS(126),WGAUSS(126)
6173
6174       DATA XGAUSS(1)/ .57735026918962576D0/
6175       DATA XGAUSS(2)/-.57735026918962576D0/
6176       DATA WGAUSS(1)/ 1.00000000000000000D0/
6177       DATA WGAUSS(2)/ 1.00000000000000000D0/
6178
6179       DATA XGAUSS(3)/ .33998104358485627D0/
6180       DATA XGAUSS(4)/ .86113631159405258D0/
6181       DATA XGAUSS(5)/-.33998104358485627D0/
6182       DATA XGAUSS(6)/-.86113631159405258D0/
6183       DATA WGAUSS(3)/ .65214515486254613D0/
6184       DATA WGAUSS(4)/ .34785484513745385D0/
6185       DATA WGAUSS(5)/ .65214515486254613D0/
6186       DATA WGAUSS(6)/ .34785484513745385D0/
6187
6188       DATA XGAUSS(7)/ .18343464249564981D0/
6189       DATA XGAUSS(8)/ .52553240991632899D0/
6190       DATA XGAUSS(9)/ .79666647741362674D0/
6191       DATA XGAUSS(10)/ .96028985649753623D0/
6192       DATA XGAUSS(11)/-.18343464249564981D0/
6193       DATA XGAUSS(12)/-.52553240991632899D0/
6194       DATA XGAUSS(13)/-.79666647741362674D0/
6195       DATA XGAUSS(14)/-.96028985649753623D0/
6196       DATA WGAUSS(7)/ .36268378337836198D0/
6197       DATA WGAUSS(8)/ .31370664587788727D0/
6198       DATA WGAUSS(9)/ .22238103445337448D0/
6199       DATA WGAUSS(10)/ .10122853629037627D0/
6200       DATA WGAUSS(11)/ .36268378337836198D0/
6201       DATA WGAUSS(12)/ .31370664587788727D0/
6202       DATA WGAUSS(13)/ .22238103445337448D0/
6203       DATA WGAUSS(14)/ .10122853629037627D0/
6204
6205       DATA XGAUSS(15)/ .0950125098376374402D0/
6206       DATA XGAUSS(16)/ .281603550779258913D0/
6207       DATA XGAUSS(17)/ .458016777657227386D0/
6208       DATA XGAUSS(18)/ .617876244402643748D0/
6209       DATA XGAUSS(19)/ .755404408355003034D0/
6210       DATA XGAUSS(20)/ .865631202387831744D0/
6211       DATA XGAUSS(21)/ .944575023073232576D0/
6212       DATA XGAUSS(22)/ .989400934991649933D0/
6213       DATA XGAUSS(23)/-.0950125098376374402D0/
6214       DATA XGAUSS(24)/-.281603550779258913D0/
6215       DATA XGAUSS(25)/-.458016777657227386D0/
6216       DATA XGAUSS(26)/-.617876244402643748D0/
6217       DATA XGAUSS(27)/-.755404408355003034D0/
6218       DATA XGAUSS(28)/-.865631202387831744D0/
6219       DATA XGAUSS(29)/-.944575023073232576D0/
6220       DATA XGAUSS(30)/-.989400934991649933D0/
6221       DATA WGAUSS(15)/ .189450610455068496D0/
6222       DATA WGAUSS(16)/ .182603415044923589D0/
6223       DATA WGAUSS(17)/ .169156519395002538D0/
6224       DATA WGAUSS(18)/ .149595988816576732D0/
6225       DATA WGAUSS(19)/ .124628971255533872D0/
6226       DATA WGAUSS(20)/ .0951585116824927848D0/
6227       DATA WGAUSS(21)/ .0622535239386478929D0/
6228       DATA WGAUSS(22)/ .0271524594117540949D0/
6229       DATA WGAUSS(23)/ .189450610455068496D0/
6230       DATA WGAUSS(24)/ .182603415044923589D0/
6231       DATA WGAUSS(25)/ .169156519395002538D0/
6232       DATA WGAUSS(26)/ .149595988816576732D0/
6233       DATA WGAUSS(27)/ .124628971255533872D0/
6234       DATA WGAUSS(28)/ .0951585116824927848D0/
6235       DATA WGAUSS(29)/ .0622535239386478929D0/
6236       DATA WGAUSS(30)/ .0271524594117540949D0/
6237
6238       DATA XGAUSS(31)/ .0483076656877383162D0/
6239       DATA XGAUSS(32)/ .144471961582796493D0/
6240       DATA XGAUSS(33)/ .239287362252137075D0/
6241       DATA XGAUSS(34)/ .331868602282127650D0/
6242       DATA XGAUSS(35)/ .421351276130635345D0/
6243       DATA XGAUSS(36)/ .506899908932229390D0/
6244       DATA XGAUSS(37)/ .587715757240762329D0/
6245       DATA XGAUSS(38)/ .663044266930215201D0/
6246       DATA XGAUSS(39)/ .732182118740289680D0/
6247       DATA XGAUSS(40)/ .794483795967942407D0/
6248       DATA XGAUSS(41)/ .849367613732569970D0/
6249       DATA XGAUSS(42)/ .896321155766052124D0/
6250       DATA XGAUSS(43)/ .934906075937739689D0/
6251       DATA XGAUSS(44)/ .964762255587506430D0/
6252       DATA XGAUSS(45)/ .985611511545268335D0/
6253       DATA XGAUSS(46)/ .997263861849481564D0/
6254       DATA XGAUSS(47)/-.0483076656877383162D0/
6255       DATA XGAUSS(48)/-.144471961582796493D0/
6256       DATA XGAUSS(49)/-.239287362252137075D0/
6257       DATA XGAUSS(50)/-.331868602282127650D0/
6258       DATA XGAUSS(51)/-.421351276130635345D0/
6259       DATA XGAUSS(52)/-.506899908932229390D0/
6260       DATA XGAUSS(53)/-.587715757240762329D0/
6261       DATA XGAUSS(54)/-.663044266930215201D0/
6262       DATA XGAUSS(55)/-.732182118740289680D0/
6263       DATA XGAUSS(56)/-.794483795967942407D0/
6264       DATA XGAUSS(57)/-.849367613732569970D0/
6265       DATA XGAUSS(58)/-.896321155766052124D0/
6266       DATA XGAUSS(59)/-.934906075937739689D0/
6267       DATA XGAUSS(60)/-.964762255587506430D0/
6268       DATA XGAUSS(61)/-.985611511545268335D0/
6269       DATA XGAUSS(62)/-.997263861849481564D0/
6270       DATA WGAUSS(31)/ .0965400885147278006D0/
6271       DATA WGAUSS(32)/ .0956387200792748594D0/
6272       DATA WGAUSS(33)/ .0938443990808045654D0/
6273       DATA WGAUSS(34)/ .0911738786957638847D0/
6274       DATA WGAUSS(35)/ .0876520930044038111D0/
6275       DATA WGAUSS(36)/ .0833119242269467552D0/
6276       DATA WGAUSS(37)/ .0781938957870703065D0/
6277       DATA WGAUSS(38)/ .0723457941088485062D0/
6278       DATA WGAUSS(39)/ .0658222227763618468D0/
6279       DATA WGAUSS(40)/ .0586840934785355471D0/
6280       DATA WGAUSS(41)/ .0509980592623761762D0/
6281       DATA WGAUSS(42)/ .0428358980222266807D0/
6282       DATA WGAUSS(43)/ .0342738629130214331D0/
6283       DATA WGAUSS(44)/ .0253920653092620595D0/
6284       DATA WGAUSS(45)/ .0162743947309056706D0/
6285       DATA WGAUSS(46)/ .00701861000947009660D0/
6286       DATA WGAUSS(47)/ .0965400885147278006D0/
6287       DATA WGAUSS(48)/ .0956387200792748594D0/
6288       DATA WGAUSS(49)/ .0938443990808045654D0/
6289       DATA WGAUSS(50)/ .0911738786957638847D0/
6290       DATA WGAUSS(51)/ .0876520930044038111D0/
6291       DATA WGAUSS(52)/ .0833119242269467552D0/
6292       DATA WGAUSS(53)/ .0781938957870703065D0/
6293       DATA WGAUSS(54)/ .0723457941088485062D0/
6294       DATA WGAUSS(55)/ .0658222227763618468D0/
6295       DATA WGAUSS(56)/ .0586840934785355471D0/
6296       DATA WGAUSS(57)/ .0509980592623761762D0/
6297       DATA WGAUSS(58)/ .0428358980222266807D0/
6298       DATA WGAUSS(59)/ .0342738629130214331D0/
6299       DATA WGAUSS(60)/ .0253920653092620595D0/
6300       DATA WGAUSS(61)/ .0162743947309056706D0/
6301       DATA WGAUSS(62)/ .00701861000947009660D0/
6302
6303       DATA XGAUSS(63)/ .02435029266342443250D0/
6304       DATA XGAUSS(64)/ .0729931217877990394D0/
6305       DATA XGAUSS(65)/ .121462819296120554D0/
6306       DATA XGAUSS(66)/ .169644420423992818D0/
6307       DATA XGAUSS(67)/ .217423643740007084D0/
6308       DATA XGAUSS(68)/ .264687162208767416D0/
6309       DATA XGAUSS(69)/ .311322871990210956D0/
6310       DATA XGAUSS(70)/ .357220158337668116D0/
6311       DATA XGAUSS(71)/ .402270157963991604D0/
6312       DATA XGAUSS(72)/ .446366017253464088D0/
6313       DATA XGAUSS(73)/ .489403145707052957D0/
6314       DATA XGAUSS(74)/ .531279464019894546D0/
6315       DATA XGAUSS(75)/ .571895646202634034D0/
6316       DATA XGAUSS(76)/ .611155355172393250D0/
6317       DATA XGAUSS(77)/ .648965471254657340D0/
6318       DATA XGAUSS(78)/ .685236313054233243D0/
6319       DATA XGAUSS(79)/ .719881850171610827D0/
6320       DATA XGAUSS(80)/ .752819907260531897D0/
6321       DATA XGAUSS(81)/ .783972358943341408D0/
6322       DATA XGAUSS(82)/ .813265315122797560D0/
6323       DATA XGAUSS(83)/ .840629296252580363D0/
6324       DATA XGAUSS(84)/ .865999398154092820D0/
6325       DATA XGAUSS(85)/ .889315445995114106D0/
6326       DATA XGAUSS(86)/ .910522137078502806D0/
6327       DATA XGAUSS(87)/ .929569172131939576D0/
6328       DATA XGAUSS(88)/ .946411374858402816D0/
6329       DATA XGAUSS(89)/ .961008799652053719D0/
6330       DATA XGAUSS(90)/ .973326827789910964D0/
6331       DATA XGAUSS(91)/ .983336253884625957D0/
6332       DATA XGAUSS(92)/ .991013371476744321D0/
6333       DATA XGAUSS(93)/ .996340116771955279D0/
6334       DATA XGAUSS(94)/ .999305041735772139D0/
6335       DATA XGAUSS(95)/-.02435029266342443250D0/
6336       DATA XGAUSS(96)/-.0729931217877990394D0/
6337       DATA XGAUSS(97)/-.121462819296120554D0/
6338       DATA XGAUSS(98)/-.169644420423992818D0/
6339       DATA XGAUSS(99)/-.217423643740007084D0/
6340       DATA XGAUSS(100)/-.264687162208767416D0/
6341       DATA XGAUSS(101)/-.311322871990210956D0/
6342       DATA XGAUSS(102)/-.357220158337668116D0/
6343       DATA XGAUSS(103)/-.402270157963991604D0/
6344       DATA XGAUSS(104)/-.446366017253464088D0/
6345       DATA XGAUSS(105)/-.489403145707052957D0/
6346       DATA XGAUSS(106)/-.531279464019894546D0/
6347       DATA XGAUSS(107)/-.571895646202634034D0/
6348       DATA XGAUSS(108)/-.611155355172393250D0/
6349       DATA XGAUSS(109)/-.648965471254657340D0/
6350       DATA XGAUSS(110)/-.685236313054233243D0/
6351       DATA XGAUSS(111)/-.719881850171610827D0/
6352       DATA XGAUSS(112)/-.752819907260531897D0/
6353       DATA XGAUSS(113)/-.783972358943341408D0/
6354       DATA XGAUSS(114)/-.813265315122797560D0/
6355       DATA XGAUSS(115)/-.840629296252580363D0/
6356       DATA XGAUSS(116)/-.865999398154092820D0/
6357       DATA XGAUSS(117)/-.889315445995114106D0/
6358       DATA XGAUSS(118)/-.910522137078502806D0/
6359       DATA XGAUSS(119)/-.929569172131939576D0/
6360       DATA XGAUSS(120)/-.946411374858402816D0/
6361       DATA XGAUSS(121)/-.961008799652053719D0/
6362       DATA XGAUSS(122)/-.973326827789910964D0/
6363       DATA XGAUSS(123)/-.983336253884625957D0/
6364       DATA XGAUSS(124)/-.991013371476744321D0/
6365       DATA XGAUSS(125)/-.996340116771955279D0/
6366       DATA XGAUSS(126)/-.999305041735772139D0/
6367       DATA WGAUSS(63)/ .0486909570091397204D0/
6368       DATA WGAUSS(64)/ .0485754674415034269D0/
6369       DATA WGAUSS(65)/ .0483447622348029572D0/
6370       DATA WGAUSS(66)/ .0479993885964583077D0/
6371       DATA WGAUSS(67)/ .0475401657148303087D0/
6372       DATA WGAUSS(68)/ .0469681828162100173D0/
6373       DATA WGAUSS(69)/ .0462847965813144172D0/
6374       DATA WGAUSS(70)/ .0454916279274181445D0/
6375       DATA WGAUSS(71)/ .0445905581637565631D0/
6376       DATA WGAUSS(72)/ .0435837245293234534D0/
6377       DATA WGAUSS(73)/ .0424735151236535890D0/
6378       DATA WGAUSS(74)/ .0412625632426235286D0/
6379       DATA WGAUSS(75)/ .0399537411327203414D0/
6380       DATA WGAUSS(76)/ .0385501531786156291D0/
6381       DATA WGAUSS(77)/ .0370551285402400460D0/
6382       DATA WGAUSS(78)/ .0354722132568823838D0/
6383       DATA WGAUSS(79)/ .0338051618371416094D0/
6384       DATA WGAUSS(80)/ .0320579283548515535D0/
6385       DATA WGAUSS(81)/ .0302346570724024789D0/
6386       DATA WGAUSS(82)/ .0283396726142594832D0/
6387       DATA WGAUSS(83)/ .0263774697150546587D0/
6388       DATA WGAUSS(84)/ .0243527025687108733D0/
6389       DATA WGAUSS(85)/ .0222701738083832542D0/
6390       DATA WGAUSS(86)/ .0201348231535302094D0/
6391       DATA WGAUSS(87)/ .0179517157756973431D0/
6392       DATA WGAUSS(88)/ .0157260304760247193D0/
6393       DATA WGAUSS(89)/ .0134630478967186426D0/
6394       DATA WGAUSS(90)/ .0111681394601311288D0/
6395       DATA WGAUSS(91)/ .00884675982636394772D0/
6396       DATA WGAUSS(92)/ .00650445796897836286D0/
6397       DATA WGAUSS(93)/ .00414703326056246764D0/
6398       DATA WGAUSS(94)/ .00178328072169643295D0/
6399       DATA WGAUSS(95)/ .0486909570091397204D0/
6400       DATA WGAUSS(96)/ .0485754674415034269D0/
6401       DATA WGAUSS(97)/ .0483447622348029572D0/
6402       DATA WGAUSS(98)/ .0479993885964583077D0/
6403       DATA WGAUSS(99)/ .0475401657148303087D0/
6404       DATA WGAUSS(100)/ .0469681828162100173D0/
6405       DATA WGAUSS(101)/ .0462847965813144172D0/
6406       DATA WGAUSS(102)/ .0454916279274181445D0/
6407       DATA WGAUSS(103)/ .0445905581637565631D0/
6408       DATA WGAUSS(104)/ .0435837245293234534D0/
6409       DATA WGAUSS(105)/ .0424735151236535890D0/
6410       DATA WGAUSS(106)/ .0412625632426235286D0/
6411       DATA WGAUSS(107)/ .0399537411327203414D0/
6412       DATA WGAUSS(108)/ .0385501531786156291D0/
6413       DATA WGAUSS(109)/ .0370551285402400460D0/
6414       DATA WGAUSS(110)/ .0354722132568823838D0/
6415       DATA WGAUSS(111)/ .0338051618371416094D0/
6416       DATA WGAUSS(112)/ .0320579283548515535D0/
6417       DATA WGAUSS(113)/ .0302346570724024789D0/
6418       DATA WGAUSS(114)/ .0283396726142594832D0/
6419       DATA WGAUSS(115)/ .0263774697150546587D0/
6420       DATA WGAUSS(116)/ .0243527025687108733D0/
6421       DATA WGAUSS(117)/ .0222701738083832542D0/
6422       DATA WGAUSS(118)/ .0201348231535302094D0/
6423       DATA WGAUSS(119)/ .0179517157756973431D0/
6424       DATA WGAUSS(120)/ .0157260304760247193D0/
6425       DATA WGAUSS(121)/ .0134630478967186426D0/
6426       DATA WGAUSS(122)/ .0111681394601311288D0/
6427       DATA WGAUSS(123)/ .00884675982636394772D0/
6428       DATA WGAUSS(124)/ .00650445796897836286D0/
6429       DATA WGAUSS(125)/ .00414703326056246764D0/
6430       DATA WGAUSS(126)/ .00178328072169643295D0/
6431 C
6432       W1 = PGAM(4,1)
6433       W2 = PGAM(4,2)
6434       bmin = b1 - 2.D0*RADSRC(1)
6435       IF (RADSRC(1) .GT. bmin) THEN
6436         bmin = RADSRC(1)
6437       ENDIF
6438       bmax = b1 + 2.D0 * RADSRC(1)
6439
6440       XINT = 0.D0
6441       DO 100 N=1,6
6442         XINT2 = XINT
6443         XINT = 0.D0
6444         DO 200 I=2**N-1,2**(N+1)-2
6445           b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
6446           XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
6447      &      * PHO_GGFNUC(W2,b2,GAMSRC(2))
6448      &      * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
6449           XINT = XINT +WGAUSS(I) * b2 * XINT3
6450  200    CONTINUE
6451         XINT = (bmax-bmin)/2.D0*XINT
6452         IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
6453  100  CONTINUE
6454       WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
6455  300  CONTINUE
6456
6457       PHO_GGFAUX = XINT
6458
6459       END
6460
6461 CDECK  ID>, PHO_GGFNUC
6462       DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
6463 C**********************************************************************
6464 C
6465 C      differential photonnumber for a nucleus (geometrical model)
6466 C      (without form factor)
6467 C
6468 C*********************************************************************
6469       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6470       SAVE
6471
6472       PARAMETER (PI = 3.14159265359D0)
6473
6474       WGamma = W/Gamma
6475       Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
6476
6477       PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
6478
6479       END
6480
6481 CDECK  ID>, PHO_GHHIOF
6482       SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
6483 C**********************************************************************
6484 C
6485 C     interface to call PHOJET (variable energy run) for
6486 C     gamma-hadron collisions in heavy ion collisions
6487 C     (form factor approach)
6488 C
6489 C     input:     EEN     LAB system energy per nucleon
6490 C                NA      atomic number of ion/hadron
6491 C                NZ      charge number of ion/hadron
6492 C                NEVENT  number of events to generate
6493 C            from /LEPCUT/:
6494 C                YMIN1,2 lower limit of Y
6495 C                        (energy fraction taken by photon from hadron)
6496 C                YMAX1,2 upper cutoff for Y, necessary to avoid
6497 C                        underflows
6498 C                Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
6499 C                Q2MAX1,2 maximum Q**2 of photons (if necessary,
6500 C                        corrected according size of hadron)
6501 C
6502 C**********************************************************************
6503       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6504       SAVE
6505
6506       PARAMETER ( PI   = 3.14159265359D0 )
6507
6508 C  input/output channels
6509       INTEGER LI,LO
6510       COMMON /POINOU/ LI,LO
6511 C  model switches and parameters
6512       CHARACTER*8 MDLNA
6513       INTEGER ISWMDL,IPAMDL
6514       DOUBLE PRECISION PARMDL
6515       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
6516 C  event debugging information
6517       INTEGER NMAXD
6518       PARAMETER (NMAXD=100)
6519       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
6520      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6521       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
6522      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6523 C  photon flux kinematics and cuts
6524       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
6525      &                 YMIN1,YMAX1,YMIN2,YMAX2,
6526      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6527      &                 THMIN1,THMAX1,THMIN2,THMAX2
6528       INTEGER          ITAG1,ITAG2
6529       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
6530      &                YMIN1,YMAX1,YMIN2,YMAX2,
6531      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6532      &                THMIN1,THMAX1,THMIN2,THMAX2,
6533      &                ITAG1,ITAG2
6534 C  gamma-lepton or gamma-hadron vertex information
6535       INTEGER IGHEL,IDPSRC,IDBSRC
6536       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6537      &                 RADSRC,AMSRC,GAMSRC
6538       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6539      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6540      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6541 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
6542       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
6543       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
6544       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
6545      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
6546
6547 C  standard particle data interface
6548       INTEGER NMXHEP
6549
6550       PARAMETER (NMXHEP=4000)
6551
6552       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
6553       DOUBLE PRECISION PHEP,VHEP
6554       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
6555      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
6556      &                VHEP(4,NMXHEP)
6557 C  extension to standard particle data interface (PHOJET specific)
6558       INTEGER IMPART,IPHIST,ICOLOR
6559       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
6560
6561 C  event weights and generated cross section
6562       INTEGER IPOWGC,ISWCUT,IVWGHT
6563       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
6564       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
6565      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
6566
6567       DIMENSION P1(4),P2(4)
6568       DIMENSION NITERS(2),ITRW(2)
6569
6570       WRITE(LO,'(2(/1X,A))')
6571      &  'PHO_GHHIOF: gamma-hadron event generation',
6572      &  '-----------------------------------------'
6573 C  hadron size and mass
6574       FM2GEV = 5.07D0
6575       HIMASS = DBLE(NA)*0.938D0
6576       HIMA2  = HIMASS**2
6577       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
6578       ALPHA  = DBLE(NZ**2)/137.D0
6579       AMP  = 0.938D0
6580       AMP2 = AMP**2
6581 C  correct Q2MAX1,2 according to hadron size
6582       Q2MAXH = 2.D0/HIRADI**2
6583       Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
6584       Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
6585       IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
6586       IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
6587 C  total hadron / heavy ion energy
6588       EE = EEN*DBLE(NA)
6589       GAMMA = EE/HIMASS
6590 C  setup /POFSRC/
6591       GAMSRC(1) = GAMMA
6592       GAMSRC(2) = GAMMA
6593       RADSRC(1) = HIRADI
6594       RADSRC(2) = HIRADI
6595       AMSRC(1)  = HIMASS
6596       AMSRC(2)  = HIMASS
6597 C  check cuts on photon-hadron mass
6598       IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
6599         YMI = ECMIN
6600         ECMIN =  PARMDL(46)/PARMDL(45)+0.1D0
6601         WRITE(LO,'(/1X,A,2E12.5)')
6602      &    'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
6603       ENDIF
6604 C  check kinematic limitations
6605       YMI = ECMIN**2/(4.D0*EE*EEN)
6606       IF(YMIN1.LT.YMI) THEN
6607         WRITE(LO,'(/1X,A,2E12.5)')
6608      &    'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
6609         YMIN1 = YMI
6610       ELSE IF(YMIN1.GT.YMI) THEN
6611         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6612      &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
6613      &    '  INSTEAD OF',YMIN1
6614       ENDIF
6615       IF(YMIN2.LT.YMI) THEN
6616         WRITE(LO,'(/1X,A,2E12.5)')
6617      &    'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
6618         YMIN2 = YMI
6619       ELSE IF(YMIN2.GT.YMI) THEN
6620         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6621      &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
6622      &    '  INSTEAD OF',YMIN2
6623       ENDIF
6624 C  kinematic limitation
6625       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6626       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6627 C  debug output
6628       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
6629       WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
6630       WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
6631       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
6632      &  Q2MAX1
6633       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
6634      &  Q2MAX2
6635       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
6636      &  YMAX1
6637       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
6638      &  YMAX2
6639       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
6640      &  2.D0*EEN,2.D0*EE
6641       WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON      ',ECMIN,
6642      &  ECMAX
6643       WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
6644      &  PARMDL(175)
6645       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
6646       IF(Q2LOW1.GE.Q2MAX1) THEN
6647         WRITE(LO,'(/1X,A,2E12.4)')
6648      &    'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
6649         CALL PHO_ABORT
6650       ENDIF
6651       IF(Q2LOW2.GE.Q2MAX2) THEN
6652         WRITE(LO,'(/1X,A,2E12.4)')
6653      &    'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
6654         CALL PHO_ABORT
6655       ENDIF
6656 C  hadron numbers set to 0
6657       IDPSRC(1) = 0
6658       IDPSRC(2) = 0
6659       IDBSRC(1) = 0
6660       IDBSRC(2) = 0
6661 C
6662       Max_tab = 100
6663       YMAX = YMAX1
6664       YMIN = YMIN1
6665       XMAX = LOG(YMAX)
6666       XMIN = LOG(YMIN)
6667       XDEL = XMAX-XMIN
6668       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6669       DO 100 I=1,Max_tab
6670         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6671         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6672         IF(Q2LOW1.GE.Q2MAX1) THEN
6673           WRITE(LO,'(/1X,A,2E12.4)')
6674      &      'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
6675           YMAX1 = MIN(Y1,YMAX1)
6676           GOTO 101
6677         ENDIF
6678  100  CONTINUE
6679  101  CONTINUE
6680       YMAX = YMAX2
6681       YMIN = YMIN2
6682       XMAX = LOG(YMAX)
6683       XMIN = LOG(YMIN)
6684       XDEL = XMAX-XMIN
6685       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6686       DO 102 I=1,Max_tab
6687         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6688         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
6689         IF(Q2LOW2.GE.Q2MAX2) THEN
6690           WRITE(LO,'(/1X,A,2E12.4)')
6691      &      'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
6692           YMAX2 = MIN(Y1,YMAX2)
6693           GOTO 103
6694         ENDIF
6695  102  CONTINUE
6696  103  CONTINUE
6697 C
6698       X1MAX = LOG(YMAX1)
6699       X1MIN = LOG(YMIN1)
6700       X1DEL = X1MAX-X1MIN
6701       X2MAX = LOG(YMAX2)
6702       X2MIN = LOG(YMIN2)
6703       X2DEL = X2MAX-X2MIN
6704       DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
6705       FLUX = 0.D0
6706       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
6707      &  'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
6708       DO 105 I=1,Max_tab
6709         Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
6710         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6711         FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
6712      &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
6713         FLUX = FLUX+Y1*FF
6714         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
6715  105  CONTINUE
6716       FLUX = FLUX*DELLY
6717       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
6718      &  'PHO_GHHIOF: integrated flux (one side):',FLUX
6719 C
6720 C  photon
6721       EGAM = MAX(YMAX1,YMAX2)*EE
6722       P1(1) = 0.D0
6723       P1(2) = 0.D0
6724       P1(3) = EGAM
6725       P1(4) = EGAM
6726 C  hadron
6727       P2(1) = 0.D0
6728       P2(2) = 0.D0
6729       P2(3) = -SQRT(EEN**2-AMP2)
6730       P2(4) = EEN
6731       CALL PHO_SETPAR(1,22,0,0.D0)
6732       CALL PHO_SETPAR(2,2212,0,0.D0)
6733       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
6734 C
6735       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6736       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6737       Y1 = YMIN1
6738       Y2 = YMIN2
6739       WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
6740      &         -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6741       WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
6742      &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6743 C
6744       IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
6745       IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
6746 C
6747       FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
6748      &       /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
6749 C
6750       CALL PHO_PHIST(-1,SIGMAX)
6751       CALL PHO_LHIST(-1,SIGMAX)
6752 C
6753 C  generation of events, flux calculation
6754
6755       AY1  = 0.D0
6756       AY2  = 0.D0
6757       AYS1 = 0.D0
6758       AYS2 = 0.D0
6759       Q21MIN = 1.D30
6760       Q22MIN = 1.D30
6761       Q21MAX = 0.D0
6762       Q22MAX = 0.D0
6763       Q21AVE = 0.D0
6764       Q22AVE = 0.D0
6765       Q21AV2 = 0.D0
6766       Q22AV2 = 0.D0
6767       YY1MIN = 1.D30
6768       YY2MIN = 1.D30
6769       YY1MAX = 0.D0
6770       YY2MAX = 0.D0
6771       NITER = NEVENT
6772       NITERS(1) = 0
6773       NITERS(2) = 0
6774       ITRY = 0
6775       ITRW(1) = 0
6776       ITRW(2) = 0
6777       DO 200 I=1,NITER
6778 C  sample y1, y2
6779  150    CONTINUE
6780         ITRY = ITRY+1
6781  175    CONTINUE
6782 C
6783 C  select side of photon emission
6784         IF(DT_RNDM(AY1).LT.FAC12) THEN
6785           ITRW(1) = ITRW(1)+1
6786 C  select Y1
6787           Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
6788           Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
6789           IF(Q2LOW1.GE.Q2MAX1) GOTO 175
6790           Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
6791           WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
6792      &          -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6793           IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6794      &        'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
6795           IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
6796 C  sample Q2
6797           IF(IPAMDL(174).EQ.1) THEN
6798             YEFF = 1.D0+(1.D0-Y1)**2
6799  185        CONTINUE
6800               Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
6801               WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
6802             IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
6803           ELSE
6804             Q2P1 = Q2LOW1
6805           ENDIF
6806 C  impact parameter
6807           GAIMP(1) = 1.D0/SQRT(Q2P1)
6808 C  form factor (squared)
6809           FF2 = 1.D0
6810           IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
6811           IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
6812 C  photon data
6813           GYY(1) = Y1
6814           GQ2(1) = Q2P1
6815
6816 C
6817 C  incoming hadron 1
6818           PINI(1,1) = 0.D0
6819           PINI(2,1) = 0.D0
6820           PINI(3,1) = SQRT(EE**2-AMP2)
6821           PINI(4,1) = EE
6822           PINI(5,1) = AMP
6823 C  outgoing hadron 1
6824           YQ2 = SQRT((1.D0-Y1)*Q2P1)
6825           Q2E = Q2P1/(4.D0*EE)
6826           E1Y = EE*(1.D0-Y1)
6827           CALL PHO_SFECFE(SIF,COF)
6828           PFIN(1,1) = YQ2*COF
6829           PFIN(2,1) = YQ2*SIF
6830           PFIN(3,1) = E1Y-Q2E
6831           PFIN(4,1) = E1Y+Q2E
6832           PFIN(5,1) = 0.D0
6833           PFPHI(1) = ATAN2(COF,SIF)
6834           PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
6835 C  incoming hadron 2
6836           PINI(1,2) = 0.D0
6837           PINI(2,2) = 0.D0
6838           PINI(3,2) = -SQRT(EE**2-AMP2)
6839           PINI(4,2) = EE
6840           PINI(5,2) = AMP
6841 C  scattering photon
6842           P1(1) = -PFIN(1,1)
6843           P1(2) = -PFIN(2,1)
6844           P1(3) = PINI(3,1)-PFIN(3,1)
6845           P1(4) = PINI(4,1)-PFIN(4,1)
6846 C  scattering hadron
6847           P2(1) = 0.D0
6848           P2(2) = 0.D0
6849           P2(3) = -SQRT(EEN**2-AMP2)
6850           P2(4) = EEN
6851           ISIDE = 1
6852 C
6853         ELSE
6854 C
6855           ITRW(2) = ITRW(2)+1
6856 C  select Y2
6857           Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
6858           Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
6859           IF(Q2LOW2.GE.Q2MAX2) GOTO 175
6860           Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
6861           WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
6862      &          -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6863           IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6864      &        'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
6865           IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
6866 C  sample Q2
6867           IF(IPAMDL(174).EQ.1) THEN
6868             YEFF = 1.D0+(1.D0-Y2)**2
6869  186        CONTINUE
6870               Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
6871               WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
6872             IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
6873           ELSE
6874             Q2P2 = Q2LOW2
6875           ENDIF
6876 C  impact parameter
6877           GAIMP(2) = 1.D0/SQRT(Q2P2)
6878 C  form factor (squared)
6879           FF2 = 1.D0
6880           IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
6881           IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
6882 C  photon data
6883           GYY(2) = Y2
6884           GQ2(2) = Q2P2
6885
6886 C
6887 C  incoming hadron 1
6888           PINI(1,1) = 0.D0
6889           PINI(2,1) = 0.D0
6890           PINI(3,1) = SQRT(EE**2-AMP2)
6891           PINI(4,1) = EE
6892           PINI(5,1) = AMP
6893 C  incoming hadron 2
6894           PINI(1,2) = 0.D0
6895           PINI(2,2) = 0.D0
6896           PINI(3,2) = -SQRT(EE**2-AMP2)
6897           PINI(4,2) = EE
6898           PINI(5,2) = AMP
6899 C  outgoing hadron 2
6900           YQ2 = SQRT((1.D0-Y2)*Q2P2)
6901           Q2E = Q2P2/(4.D0*EE)
6902           E1Y = EE*(1.D0-Y2)
6903           CALL PHO_SFECFE(SIF,COF)
6904           PFIN(1,2) = YQ2*COF
6905           PFIN(2,2) = YQ2*SIF
6906           PFIN(3,2) = -E1Y+Q2E
6907           PFIN(4,2) = E1Y+Q2E
6908           PFIN(5,2) = 0.D0
6909           PFPHI(2) = ATAN2(COF,SIF)
6910           PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
6911 C  scattering hadron
6912           P2(1) = 0.D0
6913           P2(2) = 0.D0
6914           P2(3) = SQRT(EEN**2-AMP2)
6915           P2(4) = EEN
6916 C  scattering photon
6917           P1(1) = -PFIN(1,2)
6918           P1(2) = -PFIN(2,2)
6919           P1(3) = PINI(3,2)-PFIN(3,2)
6920           P1(4) = PINI(4,2)-PFIN(4,2)
6921           ISIDE = 2
6922         ENDIF
6923 C  ECMS cut
6924         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
6925      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
6926         IF(GGECM.LT.0.1D0) GOTO 175
6927         GGECM = SQRT(GGECM)
6928         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
6929 C
6930         PGAM(1,1) = P1(1)
6931         PGAM(2,1) = P1(2)
6932         PGAM(3,1) = P1(3)
6933         PGAM(4,1) = P1(4)
6934         PGAM(5,1) = -SQRT(Q2P1)
6935         PGAM(1,2) = P2(1)
6936         PGAM(2,2) = P2(2)
6937         PGAM(3,2) = P2(3)
6938         PGAM(4,2) = P2(4)
6939         PGAM(5,2) = -SQRT(Q2P2)
6940         CALL PHO_PRESEL(5,IREJ)
6941 C  photon helicities
6942         IGHEL(1) = 1
6943         IGHEL(2) = 1
6944 C  user cuts
6945         IF(IREJ.NE.0) GOTO 175
6946 C  event generation
6947         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
6948         IF(IREJ.NE.0) GOTO 150
6949 C  cut on diffractive mass
6950         DO 250 K=1,NHEP
6951           IF(ISTHEP(K).EQ.30) THEN
6952             GHDIFF = PHEP(1,K)
6953             IF(GHDIFF.GE.PARMDL(175)) THEN
6954               GOTO 251
6955             ELSE
6956               GOTO 150
6957             ENDIF
6958           ENDIF
6959  250    CONTINUE
6960         WRITE(LO,'(/,1X,A)')
6961      &    'PHO_GHHIOF: no diffractive entry found'
6962           CALL PHO_PREVNT(-1)
6963         GOTO 150
6964  251    CONTINUE
6965 C  remove quasi-elastically scattered hadron
6966         DO 260 K=1,NHEP
6967           IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
6968             XF = ABS(PHEP(3,K)/EEN)
6969             IF(XF.LT.PARMDL(72)) GOTO 150
6970 *           ISTHEP(K) = 2
6971             GOTO 261
6972           ENDIF
6973  260    CONTINUE
6974  261    CONTINUE
6975 C
6976 C  statistics
6977
6978         NITERS(ISIDE) = NITERS(ISIDE)+1
6979         IF(ISIDE.EQ.1) THEN
6980
6981           AY1  = AY1+Y1
6982           AYS1 = AYS1+Y1*Y1
6983           Q21AVE = Q21AVE+Q2P1
6984           Q21AV2 = Q21AV2+Q2P1*Q2P1
6985           Q21MIN = MIN(Q21MIN,Q2P1)
6986           Q21MAX = MAX(Q21MAX,Q2P1)
6987           YY1MIN = MIN(YY1MIN,Y1)
6988           YY1MAX = MAX(YY1MAX,Y1)
6989         ELSE
6990
6991           AY2  = AY2+Y2
6992           AYS2 = AYS2+Y2*Y2
6993           Q22AVE = Q22AVE+Q2P2
6994           Q22AV2 = Q22AV2+Q2P2*Q2P2
6995           Q22MIN = MIN(Q22MIN,Q2P2)
6996           Q22MAX = MAX(Q22MAX,Q2P2)
6997           YY2MIN = MIN(YY2MIN,Y2)
6998           YY2MAX = MAX(YY2MAX,Y2)
6999         ENDIF
7000 C  histograms
7001         CALL PHO_PHIST(1,HSWGHT(0))
7002         CALL PHO_LHIST(1,HSWGHT(0))
7003  200  CONTINUE
7004 C
7005       WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
7006       WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
7007       WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
7008       WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
7009       AY1  = AY1/DBLE(MAX(NITERS(1),1))
7010       AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
7011       DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
7012       AY2  = AY2/DBLE(MAX(NITERS(2),1))
7013       AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
7014       DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
7015       Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
7016       Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
7017       Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
7018       Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
7019       Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
7020       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
7021       WGMAX  = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
7022       WGY    = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
7023       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7024 C  output of statistics, histograms
7025       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7026      &'=========================================================',
7027      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
7028      &'========================================================='
7029       WRITE(LO,'(//1X,A,/3X,6I12)')
7030      &  'PHO_GHHIOF:SUMMARY:  NITER,   NITERS1/2,   ITRY,    ITRW1,2',
7031      &  NITER,NITERS,ITRY,ITRW
7032       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7033      &  WGY,WEIGHT
7034       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
7035      &  AY1,DAY1
7036       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
7037      &  AY2,DAY2
7038       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
7039      &  YY1MIN,YY1MAX
7040       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
7041      &  YY2MIN,YY2MAX
7042       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1      ',
7043      &  Q21AVE,Q21AV2
7044       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1    ',
7045      &  Q21MIN,Q21MAX
7046       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
7047      &  Q22AVE,Q22AV2
7048       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
7049      &  Q22MIN,Q22MAX
7050 C
7051       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7052       IF(NITER.GT.1) THEN
7053         CALL PHO_PHIST(-2,WEIGHT)
7054         CALL PHO_LHIST(-2,WEIGHT)
7055       ELSE
7056         WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
7057       ENDIF
7058
7059       END
7060
7061 CDECK  ID>, PHO_GHHIAS
7062       SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
7063 C**********************************************************************
7064 C
7065 C     interface to call PHOJET (variable energy run) for
7066 C     gamma-hadron collisions in heavy ion - hadron
7067 C     collisions (form factor approach)
7068 C
7069 C     input:     EEP     LAB system energy of proton (GeV)
7070 C                EEN     LAB system energy per nucleon (GeV)
7071 C                NA      atomic number of ion/hadron
7072 C                NZ      charge number of ion/hadron
7073 C                NEVENT  number of events to generate
7074 C            from /LEPCUT/:
7075 C                YMIN2   lower limit of Y
7076 C                        (energy fraction taken by photon from hadron)
7077 C                YMAX2   upper cutoff for Y, necessary to avoid
7078 C                        underflows
7079 C                Q2MIN2  minimum Q**2 of photons (should be set to 0)
7080 C                Q2MAX2  maximum Q**2 of photons (if necessary,
7081 C                        corrected according size of hadron)
7082 C
7083 C**********************************************************************
7084       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7085       SAVE
7086
7087       PARAMETER ( PI   = 3.14159265359D0 )
7088
7089 C  input/output channels
7090       INTEGER LI,LO
7091       COMMON /POINOU/ LI,LO
7092 C  model switches and parameters
7093       CHARACTER*8 MDLNA
7094       INTEGER ISWMDL,IPAMDL
7095       DOUBLE PRECISION PARMDL
7096       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7097 C  event debugging information
7098       INTEGER NMAXD
7099       PARAMETER (NMAXD=100)
7100       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7101      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7102       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7103      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7104 C  photon flux kinematics and cuts
7105       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
7106      &                 YMIN1,YMAX1,YMIN2,YMAX2,
7107      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7108      &                 THMIN1,THMAX1,THMIN2,THMAX2
7109       INTEGER          ITAG1,ITAG2
7110       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
7111      &                YMIN1,YMAX1,YMIN2,YMAX2,
7112      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7113      &                THMIN1,THMAX1,THMIN2,THMAX2,
7114      &                ITAG1,ITAG2
7115 C  gamma-lepton or gamma-hadron vertex information
7116       INTEGER IGHEL,IDPSRC,IDBSRC
7117       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
7118      &                 RADSRC,AMSRC,GAMSRC
7119       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
7120      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
7121      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
7122 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
7123       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
7124       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
7125       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
7126      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
7127
7128 C  standard particle data interface
7129       INTEGER NMXHEP
7130
7131       PARAMETER (NMXHEP=4000)
7132
7133       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
7134       DOUBLE PRECISION PHEP,VHEP
7135       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
7136      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
7137      &                VHEP(4,NMXHEP)
7138 C  extension to standard particle data interface (PHOJET specific)
7139       INTEGER IMPART,IPHIST,ICOLOR
7140       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
7141
7142 C  event weights and generated cross section
7143       INTEGER IPOWGC,ISWCUT,IVWGHT
7144       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
7145       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
7146      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
7147
7148       DIMENSION P1(4),P2(4)
7149
7150       WRITE(LO,'(2(/1X,A))')
7151      &  'PHO_GHHIAS: hadron-gamma event generation',
7152      &  '-----------------------------------------'
7153 C  hadron size and mass
7154       FM2GEV = 5.07D0
7155       HIMASS = DBLE(NA)*0.938D0
7156       HIMA2  = HIMASS**2
7157       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
7158       ALPHA  = DBLE(NZ**2)/137.D0
7159       AMP  = 0.938D0
7160       AMP2 = AMP**2
7161 C  correct Q2MAX2 according to hadron size
7162       Q2MAXH = 2.D0/HIRADI**2
7163       Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
7164       IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
7165 C  total hadron / heavy ion energy
7166       EE = EEN*DBLE(NA)
7167       GAMMA = EE/HIMASS
7168 C  setup /POFSRC/
7169       GAMSRC(2) = GAMMA
7170       RADSRC(2) = HIRADI
7171       AMSRC(2)  = HIMASS
7172 C  check kinematic limitations
7173       YMI = ECMIN**2/(4.D0*EE*EEP)
7174       IF(YMIN2.LT.YMI) THEN
7175         WRITE(LO,'(/1X,A,2E12.5)')
7176      &    'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
7177         YMIN2 = YMI
7178       ELSE IF(YMIN2.GT.YMI) THEN
7179         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
7180      &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
7181      &    '  INSTEAD OF',YMIN2
7182       ENDIF
7183 C  kinematic limitation
7184       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7185 C  debug output
7186       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
7187       WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV)        ',HIMASS
7188       WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION  RADIUS (GeV**-1) ',HIRADI
7189       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
7190      &  Q2MAX2
7191       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
7192      &  YMAX2
7193       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
7194      &  2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
7195       WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON      ',ECMIN,
7196      &  ECMAX
7197       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
7198       IF(Q2LOW2.GE.Q2MAX2) THEN
7199         WRITE(LO,'(/1X,A,2E12.4)')
7200      &    'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
7201         CALL PHO_ABORT
7202       ENDIF
7203 C  hadron numbers set to 0
7204       IDPSRC(1) = 0
7205       IDPSRC(2) = 0
7206       IDBSRC(1) = 0
7207       IDBSRC(2) = 0
7208 C
7209       Max_tab = 100
7210       YMAX = YMAX2
7211       YMIN = YMIN2
7212       XMAX = LOG(YMAX)
7213       XMIN = LOG(YMIN)
7214       XDEL = XMAX-XMIN
7215       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
7216       DO 102 I=1,Max_tab
7217         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
7218         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
7219         IF(Q2LOW2.GE.Q2MAX2) THEN
7220           WRITE(LO,'(/1X,A,2E12.4)')
7221      &      'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
7222           YMAX2 = MIN(Y1,YMAX2)
7223           GOTO 103
7224         ENDIF
7225  102  CONTINUE
7226  103  CONTINUE
7227 C
7228       X2MAX = LOG(YMAX2)
7229       X2MIN = LOG(YMIN2)
7230       X2DEL = X2MAX-X2MIN
7231       DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
7232       FLUX = 0.D0
7233       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
7234      &  'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
7235       DO 105 I=1,Max_tab
7236         Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
7237         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
7238         FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
7239      &        -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
7240         FLUX = FLUX+Y2*FF
7241         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
7242  105  CONTINUE
7243       FLUX = FLUX*DELLY
7244       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
7245      &  'PHO_GHHIAS: integrated flux:',FLUX
7246 C
7247 C  hadron
7248       P1(1) = 0.D0
7249       P1(2) = 0.D0
7250       P1(3) = -SQRT(EEP**2-AMP2)
7251       P1(4) = EEP
7252 C  photon
7253       EGAM = YMAX2*EE
7254       P2(1) = 0.D0
7255       P2(2) = 0.D0
7256       P2(3) = EGAM
7257       P2(4) = EGAM
7258       CALL PHO_SETPAR(1,2212,0,0.D0)
7259       CALL PHO_SETPAR(2,22,0,0.D0)
7260       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
7261 C
7262       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7263       Y2 = YMIN2
7264       WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
7265      &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7266 C
7267       CALL PHO_PHIST(-1,SIGMAX)
7268       CALL PHO_LHIST(-1,SIGMAX)
7269 C
7270 C  generation of events, flux calculation
7271
7272       AY1  = 0.D0
7273       AY2  = 0.D0
7274       AYS1 = 0.D0
7275       AYS2 = 0.D0
7276       Q22MIN = 1.D30
7277       Q22MAX = 0.D0
7278       Q22AVE = 0.D0
7279       Q22AV2 = 0.D0
7280       YY2MIN = 1.D30
7281       YY2MAX = 0.D0
7282       NITER = NEVENT
7283       NITERS = 0
7284       ITRY = 0
7285       ITRW = 0
7286       DO 200 I=1,NITER
7287 C  sample photon flux
7288  150    CONTINUE
7289         ITRY = ITRY+1
7290  175    CONTINUE
7291 C
7292           ITRW = ITRW+1
7293 C  select Y2
7294           Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
7295           Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
7296           IF(Q2LOW2.GE.Q2MAX2) GOTO 175
7297           Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
7298           WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
7299      &          -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7300           IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
7301      &        'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
7302           IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
7303 C  sample Q2
7304           IF(IPAMDL(174).EQ.1) THEN
7305             YEFF = 1.D0+(1.D0-Y2)**2
7306  186        CONTINUE
7307               Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
7308               WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
7309             IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
7310           ELSE
7311             Q2P2 = Q2LOW2
7312           ENDIF
7313 C  impact parameter
7314           GAIMP(2) = 1.D0/SQRT(Q2P2)
7315 C  form factor (squared)
7316           FF2 = 1.D0
7317           IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
7318           IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
7319 C  photon data
7320           GYY(2) = Y2
7321           GQ2(2) = Q2P2
7322
7323 C
7324 C  incoming hadron 1
7325           PINI(1,1) = 0.D0
7326           PINI(2,1) = 0.D0
7327           PINI(3,1) = SQRT(EEP**2-AMP2)
7328           PINI(4,1) = EEP
7329           PINI(5,1) = AMP
7330 C  incoming hadron 2
7331           PINI(1,2) = 0.D0
7332           PINI(2,2) = 0.D0
7333           PINI(3,2) = -SQRT(EE**2-AMP2)
7334           PINI(4,2) = EE
7335           PINI(5,2) = AMP
7336 C  outgoing hadron 2
7337           YQ2 = SQRT((1.D0-Y2)*Q2P2)
7338           Q2E = Q2P2/(4.D0*EE)
7339           E1Y = EE*(1.D0-Y2)
7340           CALL PHO_SFECFE(SIF,COF)
7341           PFIN(1,2) = YQ2*COF
7342           PFIN(2,2) = YQ2*SIF
7343           PFIN(3,2) = -E1Y+Q2E
7344           PFIN(4,2) = E1Y+Q2E
7345           PFIN(5,2) = 0.D0
7346           PFPHI(2) = ATAN2(COF,SIF)
7347           PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
7348 C  scattering hadron
7349           P1(1) = 0.D0
7350           P1(2) = 0.D0
7351           P1(3) = SQRT(EEP**2-AMP2)
7352           P1(4) = EEP
7353           Q2P1  = AMP2
7354 C  scattering photon
7355           P2(1) = -PFIN(1,2)
7356           P2(2) = -PFIN(2,2)
7357           P2(3) = PINI(3,2)-PFIN(3,2)
7358           P2(4) = PINI(4,2)-PFIN(4,2)
7359           ISIDE = 2
7360 C
7361 C  ECMS cut
7362         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
7363      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
7364         IF(GGECM.LT.0.1D0) GOTO 175
7365         GGECM = SQRT(GGECM)
7366         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
7367 C
7368         PGAM(1,1) = P1(1)
7369         PGAM(2,1) = P1(2)
7370         PGAM(3,1) = P1(3)
7371         PGAM(4,1) = P1(4)
7372         PGAM(5,1) = AMP
7373         PGAM(1,2) = P2(1)
7374         PGAM(2,2) = P2(2)
7375         PGAM(3,2) = P2(3)
7376         PGAM(4,2) = P2(4)
7377         PGAM(5,2) = -SQRT(Q2P2)
7378 C  photon helicities
7379         IGHEL(2) = 1
7380 C  user cuts
7381         CALL PHO_PRESEL(5,IREJ)
7382         IF(IREJ.NE.0) GOTO 175
7383 C  event generation
7384         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
7385         IF(IREJ.NE.0) GOTO 150
7386 C  cut on diffractive mass
7387         DO 250 K=1,NHEP
7388           IF(ISTHEP(K).EQ.30) THEN
7389             GHDIFF = PHEP(1,K)
7390             IF(GHDIFF.GE.PARMDL(175)) THEN
7391               GOTO 251
7392             ELSE
7393               GOTO 150
7394             ENDIF
7395           ENDIF
7396  250    CONTINUE
7397         WRITE(LO,'(/,1X,A)')
7398      &    'PHO_GHHIOF: no diffractive entry found'
7399           CALL PHO_PREVNT(-1)
7400         GOTO 150
7401  251    CONTINUE
7402 C  remove quasi-elastically scattered hadron
7403         DO 260 K=1,NHEP
7404           IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7405             XF = ABS(PHEP(3,K)/EEN)
7406             IF(XF.LT.PARMDL(72)) GOTO 150
7407 *           ISTHEP(K) = 2
7408             GOTO 261
7409           ENDIF
7410  260    CONTINUE
7411  261    CONTINUE
7412 C
7413 C  statistics
7414
7415         NITERS = NITERS+1
7416
7417         AY2  = AY2+Y2
7418         AYS2 = AYS2+Y2*Y2
7419         Q22AVE = Q22AVE+Q2P2
7420         Q22AV2 = Q22AV2+Q2P2*Q2P2
7421         Q22MIN = MIN(Q22MIN,Q2P2)
7422         Q22MAX = MAX(Q22MAX,Q2P2)
7423         YY2MIN = MIN(YY2MIN,Y2)
7424         YY2MAX = MAX(YY2MAX,Y2)
7425 C  histograms
7426         CALL PHO_PHIST(1,HSWGHT(0))
7427         CALL PHO_LHIST(1,HSWGHT(0))
7428  200  CONTINUE
7429 C
7430       WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7431       WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
7432       AY2  = AY2/DBLE(MAX(NITERS,1))
7433       AYS2 = AYS2/DBLE(MAX(NITERS,1))
7434       DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
7435       Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
7436       Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
7437       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
7438       WGMAX  = WGMAX2*LOG(YMAX2/YMIN2)
7439       WGY    = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
7440       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7441 C  output of statistics, histograms
7442       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7443      &'=========================================================',
7444      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
7445      &'========================================================='
7446       WRITE(LO,'(//1X,A,/3X,4I12)')
7447      &  'PHO_GHHIOF:SUMMARY:  NITER,    NITERS,    ITRY,     ITRW',
7448      &  NITER,NITERS,ITRY,ITRW
7449       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7450      &  WGY,WEIGHT
7451       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
7452      &  AY2,DAY2
7453       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
7454      &  YY2MIN,YY2MAX
7455       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
7456      &  Q22AVE,Q22AV2
7457       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
7458      &  Q22MIN,Q22MAX
7459 C
7460       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7461       IF(NITER.GT.1) THEN
7462         CALL PHO_PHIST(-2,WEIGHT)
7463         CALL PHO_LHIST(-2,WEIGHT)
7464       ELSE
7465         WRITE(LO,'(1X,A,I4)')
7466      &    'PHO_GHHIOF: no output of histograms',NITER
7467       ENDIF
7468
7469       END
7470
7471 CDECK  ID>, PHO_FITPAR
7472       SUBROUTINE PHO_FITPAR(IOUTP)
7473 C**********************************************************************
7474 C
7475 C     read input parameters according to PDFs
7476 C
7477 C**********************************************************************
7478       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7479       SAVE
7480
7481       PARAMETER ( DEFA=-99999.D0,
7482      &            DEFB=-100000.D0,
7483      &           THOUS=1.D3)
7484
7485 C  input/output channels
7486       INTEGER LI,LO
7487       COMMON /POINOU/ LI,LO
7488 C  event debugging information
7489       INTEGER NMAXD
7490       PARAMETER (NMAXD=100)
7491       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7492      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7493       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7494      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7495 C  model switches and parameters
7496       CHARACTER*8 MDLNA
7497       INTEGER ISWMDL,IPAMDL
7498       DOUBLE PRECISION PARMDL
7499       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7500 C  global event kinematics and particle IDs
7501       INTEGER IFPAP,IFPAB
7502       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
7503       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
7504 C  currently activated parton density parametrizations
7505       CHARACTER*8 PDFNAM
7506       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
7507       DOUBLE PRECISION PDFLAM,PDFQ2M
7508       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
7509      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
7510 C  Reggeon phenomenology parameters
7511       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
7512      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
7513       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
7514      &                ALREG,ALREGP,GR(2),B0REG(2),
7515      &                GPPP,GPPR,B0PPP,B0PPR,
7516      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
7517 C  parameters of 2x2 channel model
7518       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
7519       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
7520
7521       DIMENSION   INUM(3),IFPAS(2)
7522       CHARACTER*8 CNAME8,PDFNA1,PDFNA2
7523       CHARACTER*10 CNAM10
7524
7525       PARAMETER ( Max_tab = 22 )
7526       DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
7527       REAL XDPtab
7528       INTEGER IDPtab
7529
7530 C  parameter set for   2212 (GRV94 LO)     2212 (GRV94 LO)
7531       DATA (IDPtab(k,  1),k=1,8) /
7532      &    2212,     5,     6,     0,  2212,     5,     6,     0 /
7533       DATA (XDPtab(k,  1),k=1,27) /
7534      &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7535      &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
7536      &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7537      &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7538      &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7539
7540 C  parameter set for   2212 (GRV94 LO)    -2212 (GRV94 LO)
7541       DATA (IDPtab(k,  2),k=1,8) /
7542      &    2212,     5,     6,     0, -2212,     5,     6,     0 /
7543       DATA (XDPtab(k,  2),k=1,27) /
7544      &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7545      &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
7546      &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7547      &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7548      &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7549
7550 C  parameter set for     22 (GRV-G LO)     2212 (GRV94 LO)
7551       DATA (IDPtab(k,  3),k=1,8) /
7552      &      22,     5,     3,     0,  2212,     5,     6,     0 /
7553       DATA (XDPtab(k,  3),k=1,27) /
7554      &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7555      &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7556      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7557      &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7558      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7559
7560 C  parameter set for     22 (GRV-G LO)       22 (GRV-G LO)
7561       DATA (IDPtab(k,  4),k=1,8) /
7562      &      22,     5,     3,     0,    22,     5,     3,     0 /
7563       DATA (XDPtab(k,  4),k=1,27) /
7564      &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7565      &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7566      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7567      &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7568      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7569
7570 C  parameter set for     22 (GRS-G LO)     2212 (GRV94 LO)
7571       DATA (IDPtab(k,  5),k=1,8) /
7572      &      22,     5,     4,     4,  2212,     5,     6,     0 /
7573       DATA (XDPtab(k,  5),k=1,27) /
7574      &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7575      &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7576      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7577      &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7578      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7579
7580 C  parameter set for     22 (GRS-G LO)       22 (GRS-G LO)
7581       DATA (IDPtab(k,  6),k=1,8) /
7582      &      22,     5,     4,     4,    22,     5,     4,     4 /
7583       DATA (XDPtab(k,  6),k=1,27) /
7584      &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7585      &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7586      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7587      &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7588      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7589
7590 C  parameter set for     22 (SaS-1D  )       22 (SaS-1D  )
7591       DATA (IDPtab(k,  7),k=1,8) /
7592      &      22,     1,     1,     4,    22,     1,     1,     4 /
7593       DATA (XDPtab(k,  7),k=1,27) /
7594      &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
7595      &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
7596      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7597      &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
7598      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7599
7600 C  parameter set for     22 (SaS-1M  )       22 (SaS-1M  )
7601       DATA (IDPtab(k,  8),k=1,8) /
7602      &      22,     1,     2,     4,    22,     1,     2,     4 /
7603       DATA (XDPtab(k,  8),k=1,27) /
7604      &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
7605      &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
7606      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7607      &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,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 (SaS-2D  )       22 (SaS-2D  )
7611       DATA (IDPtab(k,  9),k=1,8) /
7612      &      22,     1,     3,     4,    22,     1,     3,     4 /
7613       DATA (XDPtab(k,  9),k=1,27) /
7614      &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
7615      &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
7616      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7617      &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7618      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7619
7620 C  parameter set for     22 (SaS-2M  )       22 (SaS-2M  )
7621       DATA (IDPtab(k, 10),k=1,8) /
7622      &      22,     1,     4,     4,    22,     1,     4,     4 /
7623       DATA (XDPtab(k, 10),k=1,27) /
7624      &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
7625      &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
7626      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7627      &4.6600E-03,3.0000E-05,4.6600E-03,3.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 (LAC     )     2212 (GRV94 LO)
7631       DATA (IDPtab(k, 11),k=1,8) /
7632      &      22,     3,     1,     3,  2212,     5,     6,     0 /
7633       DATA (XDPtab(k, 11),k=1,27) /
7634      &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7635      &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7636      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7637      &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7638      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7639
7640 C  parameter set for     22 (PDFLIB2 )     2212 (GRV94 LO)
7641       DATA (IDPtab(k, 12),k=1,8) /
7642      &      22,     3,     1,     2,  2212,     5,     6,     0 /
7643       DATA (XDPtab(k, 12),k=1,27) /
7644      &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7645      &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7646      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7647      &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7648      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7649
7650 C  parameter set for     22 (LAC     )       22 (LAC     )
7651       DATA (IDPtab(k, 13),k=1,8) /
7652      &      22,     3,     1,     3,    22,     3,     1,     3 /
7653       DATA (XDPtab(k, 13),k=1,27) /
7654      &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7655      &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7656      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7657      &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+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 (PDFLIB2 )       22 (PDFLIB2 )
7661       DATA (IDPtab(k, 14),k=1,8) /
7662      &      22,     3,     1,     2,    22,     3,     1,     2 /
7663       DATA (XDPtab(k, 14),k=1,27) /
7664      &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7665      &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7666      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7667      &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+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, 15),k=1,8) /
7672      &      22,     3,     2,     3,  2212,     5,     6,     0 /
7673       DATA (XDPtab(k, 15),k=1,27) /
7674      &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7675      &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7676      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7677      &3.8700E-03,1.1000E-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, 16),k=1,8) /
7682      &      22,     3,     2,     2,  2212,     5,     6,     0 /
7683       DATA (XDPtab(k, 16),k=1,27) /
7684      &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7685      &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7686      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7687      &3.8700E-03,1.1000E-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, 17),k=1,8) /
7692      &      22,     3,     2,     3,    22,     3,     2,     3 /
7693       DATA (XDPtab(k, 17),k=1,27) /
7694      &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7695      &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7696      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7697      &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-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, 18),k=1,8) /
7702      &      22,     3,     2,     2,    22,     3,     2,     2 /
7703       DATA (XDPtab(k, 18),k=1,27) /
7704      &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7705      &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7706      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7707      &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-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, 19),k=1,8) /
7712      &      22,     3,     3,     3,  2212,     5,     6,     0 /
7713       DATA (XDPtab(k, 19),k=1,27) /
7714      &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7715      &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7716      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7717      &4.0200E-03,1.0000E-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, 20),k=1,8) /
7722      &      22,     3,     3,     2,  2212,     5,     6,     0 /
7723       DATA (XDPtab(k, 20),k=1,27) /
7724      &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7725      &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7726      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7727      &4.0200E-03,1.0000E-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, 21),k=1,8) /
7732      &      22,     3,     3,     3,    22,     3,     3,     3 /
7733       DATA (XDPtab(k, 21),k=1,27) /
7734      &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7735      &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7736      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7737      &4.0200E-03,1.0000E-04,4.0200E-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, 22),k=1,8) /
7742      &      22,     3,     3,     2,    22,     3,     3,     2 /
7743       DATA (XDPtab(k, 22),k=1,27) /
7744      &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7745      &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7746      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7747      &4.0200E-03,1.0000E-04,4.0200E-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       DATA CNAME8 /'        '/
7751       DATA CNAM10 /'          '/
7752       DATA INIT / 0 /
7753       DATA IFPAS / 0, 0 /
7754
7755       IF((INIT.EQ.1).AND.
7756      &   (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
7757
7758       INIT=1
7759       IFPAS(1) = IFPAP(1)
7760       IFPAS(2) = IFPAP(2)
7761
7762 C  parton distribution functions
7763       CALL PHO_ACTPDF(IFPAP(1),1)
7764       CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7765       CALL PHO_ACTPDF(IFPAP(2),2)
7766       CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7767 C  initialize alpha_s calculation
7768       DUMMY = PHO_ALPHAS(0.D0,-4)
7769
7770       IF(IDEB(54).GE.0) THEN
7771         WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7772      &    IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
7773         WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7774      &    IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
7775       ENDIF
7776
7777       IFOUND = 0
7778
7779 C  load parameter set from internal tables
7780       I1 = 1
7781       I2 = 2
7782  110  CONTINUE
7783
7784       DO I=1,Max_tab
7785         IF((IFPAP(I1).EQ.IDPtab(1,I))
7786      &     .AND.(IGRP(I1).EQ.IDPtab(2,I))
7787      &     .AND.(ISET(I1).EQ.IDPtab(3,I))
7788      &     .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
7789           IF((IFPAP(I2).EQ.IDPtab(5,I))
7790      &       .AND.(IGRP(I2).EQ.IDPtab(6,I))
7791      &       .AND.(ISET(I2).EQ.IDPtab(7,I))
7792      &       .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
7793 C *** Commented by Chiara
7794 C            WRITE(LO,'(/1X,A)')
7795 C     &        'PHO_FITPAR: parameter set found in internal table'
7796             ALPOM    = XDPtab(1,I)
7797             ALPOMP   = XDPtab(2,I)
7798             GP(I1)   = XDPtab(3,I)
7799             GP(I2)   = XDPtab(4,I)
7800             B0POM(I1) = XDPtab(5,I)
7801             B0POM(I2) = XDPtab(6,I)
7802             ALREG    = XDPtab(7,I)
7803             ALREGP   = XDPtab(8,I)
7804             GR(I1)   = XDPtab(9,I)
7805             GR(I2)   = XDPtab(10,I)
7806             B0REG(I1) = XDPtab(11,I)
7807             B0REG(I2) = XDPtab(12,I)
7808             GPPP     = XDPtab(13,I)
7809             B0PPP    = XDPtab(14,I)
7810             GPPR     = XDPtab(15,I)
7811             B0PPR    = XDPtab(16,I)
7812             VDMFAC(2*I1-1) = XDPtab(17,I)
7813             VDMFAC(2*I1)   = XDPtab(18,I)
7814             VDMFAC(2*I2-1) = XDPtab(19,I)
7815             VDMFAC(2*I2)   = XDPtab(20,I)
7816             B0HAR    = XDPtab(21,I)
7817             AKFAC    = XDPtab(22,I)
7818             PHISUP(I1) = XDPtab(23,I)
7819             PHISUP(I2) = XDPtab(24,I)
7820             RMASS(I1) = XDPtab(25,I)
7821             RMASS(I2) = XDPtab(26,I)
7822             VAR      = XDPtab(27,I)
7823             IFOUND = 1
7824             GOTO 1200
7825           ENDIF
7826         ENDIF
7827       ENDDO
7828
7829       IF(I1.EQ.1) THEN
7830         I1 = 2
7831         I2 = 1
7832         GOTO 110
7833       ELSE
7834 C *** Commented by Chiara
7835 C        WRITE(LO,'(/1X,A)')
7836 C     &    'PHO_FITPAR: parameter set not found in internal table'
7837       ENDIF
7838
7839  1200 CONTINUE
7840
7841 C  get parameters of soft cross sections from fitpar.dat
7842       IF(IPAMDL(99).GT.IFOUND) THEN
7843
7844         WRITE(LO,'(/1X,A)')
7845      &    'PHO_FITPAR: loading parameter set from file fitpar.dat'
7846         OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
7847
7848  100    CONTINUE
7849           READ(12,'(A8)',ERR=1020,END=1010) CNAME8
7850           IF(CNAME8.EQ.'STOP') GOTO 1010
7851           IF(CNAME8.EQ.'NEXTDATA') THEN
7852             READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7853      &        IDPA1,CNAME8,INUM
7854             IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
7855      &         .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
7856               READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7857      &          IDPA2,CNAME8,INUM
7858               IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
7859      &           (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
7860                 WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
7861                 READ(12,*) ALPOM,ALPOMP,GP,B0POM
7862                 READ(12,*) ALREG,ALREGP,GR,B0REG
7863                 READ(12,*) GPPP,B0PPP,GPPR,B0PPR
7864                 READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
7865                 READ(12,*) B0HAR
7866                 READ(12,*) AKFAC
7867                 READ(12,*) PHISUP
7868                 READ(12,*) RMASS,VAR
7869                 IFOUND = 1
7870                 GOTO 1100
7871               ENDIF
7872             ENDIF
7873           ENDIF
7874         GOTO 100
7875
7876  1020 CONTINUE
7877         WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
7878         WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
7879  1010 CONTINUE
7880         WRITE(LO,'(/A)')
7881      &    ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
7882
7883  1100   CONTINUE
7884         CLOSE(12)
7885
7886       ENDIF
7887
7888 C  nothing found
7889       IF(IFOUND.EQ.0) THEN
7890         WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
7891         WRITE(LO,'(3(10X,A,/))')
7892      &    '(copy fitpar.dat into the working directory and/or',
7893      &    ' request the missing parameter set via e-mail from',
7894      &    ' eng@lepton.bartol.udel.edu)'
7895         STOP
7896       ENDIF
7897
7898  1300 CONTINUE
7899
7900 C  overwrite parameters with user settings
7901       IF(PARMDL(301).GT.DEFA) THEN
7902         ALPOM     = PARMDL(301)
7903         PARMDL(301) = DEFB
7904       ENDIF
7905       IF(PARMDL(302).GT.DEFA) THEN
7906         ALPOMP    = PARMDL(302)
7907         PARMDL(302) = DEFB
7908       ENDIF
7909       IF(PARMDL(303).GT.DEFA) THEN
7910         GP(1)     = PARMDL(303)
7911         PARMDL(303) = DEFB
7912       ENDIF
7913       IF(PARMDL(304).GT.DEFA) THEN
7914         GP(2)     = PARMDL(304)
7915         PARMDL(304) = DEFB
7916       ENDIF
7917       IF(PARMDL(305).GT.DEFA) THEN
7918         B0POM(1)  = PARMDL(305)
7919         PARMDL(305) = DEFB
7920       ENDIF
7921       IF(PARMDL(306).GT.DEFA) THEN
7922         B0POM(2)  = PARMDL(306)
7923         PARMDL(306) = DEFB
7924       ENDIF
7925       IF(PARMDL(307).GT.DEFA) THEN
7926         ALREG     = PARMDL(307)
7927         PARMDL(307) = DEFB
7928       ENDIF
7929       IF(PARMDL(308).GT.DEFA) THEN
7930         ALREGP    = PARMDL(308)
7931         PARMDL(308) = DEFB
7932       ENDIF
7933       IF(PARMDL(309).GT.DEFA) THEN
7934         GR(1)     = PARMDL(309)
7935         PARMDL(309) = DEFB
7936       ENDIF
7937       IF(PARMDL(310).GT.DEFA) THEN
7938         GR(2)      = PARMDL(310)
7939         PARMDL(310) = DEFB
7940       ENDIF
7941       IF(PARMDL(311).GT.DEFA) THEN
7942         B0REG(1)  = PARMDL(311)
7943         PARMDL(311) = DEFB
7944       ENDIF
7945       IF(PARMDL(312).GT.DEFA) THEN
7946         B0REG(2)  = PARMDL(312)
7947         PARMDL(312) = DEFB
7948       ENDIF
7949       IF(PARMDL(313).GT.DEFA) THEN
7950         GPPP      = PARMDL(313)
7951         PARMDL(313) = DEFB
7952       ENDIF
7953       IF(PARMDL(314).GT.DEFA) THEN
7954         B0PPP     = PARMDL(314)
7955         PARMDL(314)= DEFB
7956       ENDIF
7957       IF(PARMDL(315).GT.DEFA) THEN
7958         VDMFAC(1) = PARMDL(315)
7959         PARMDL(315)= DEFB
7960       ENDIF
7961       IF(PARMDL(316).GT.DEFA) THEN
7962         VDMFAC(2) = PARMDL(316)
7963         PARMDL(316)= DEFB
7964       ENDIF
7965       IF(PARMDL(317).GT.DEFA) THEN
7966         VDMFAC(3) = PARMDL(317)
7967         PARMDL(317)= DEFB
7968       ENDIF
7969       IF(PARMDL(318).GT.DEFA) THEN
7970         VDMFAC(4) = PARMDL(318)
7971         PARMDL(318)= DEFB
7972       ENDIF
7973       IF(PARMDL(319).GT.DEFA) THEN
7974         B0HAR     = PARMDL(319)
7975         PARMDL(319)= DEFB
7976       ENDIF
7977       IF(PARMDL(320).GT.DEFA) THEN
7978         AKFAC     = PARMDL(320)
7979         PARMDL(320)= DEFB
7980       ENDIF
7981       IF(PARMDL(321).GT.DEFA) THEN
7982         PHISUP(1) = PARMDL(321)
7983         PARMDL(321)= DEFB
7984       ENDIF
7985       IF(PARMDL(322).GT.DEFA) THEN
7986         PHISUP(2) = PARMDL(322)
7987         PARMDL(322)= DEFB
7988       ENDIF
7989       IF(PARMDL(323).GT.DEFA) THEN
7990         RMASS(1)  = PARMDL(323)
7991         PARMDL(323)= DEFB
7992       ENDIF
7993       IF(PARMDL(324).GT.DEFA) THEN
7994         RMASS(2)  = PARMDL(324)
7995         PARMDL(324)= DEFB
7996       ENDIF
7997       IF(PARMDL(325).GT.DEFA) THEN
7998         VAR       = PARMDL(325)
7999         PARMDL(325)= DEFB
8000       ENDIF
8001       IF(PARMDL(327).GT.DEFA) THEN
8002         GPPR      = PARMDL(327)
8003         PARMDL(327)= DEFB
8004       ENDIF
8005       IF(PARMDL(328).GT.DEFA) THEN
8006         B0PPR     = PARMDL(328)
8007         PARMDL(328)= DEFB
8008       ENDIF
8009
8010       VDMQ2F(1) = VDMFAC(1)
8011       VDMQ2F(2) = VDMFAC(2)
8012       VDMQ2F(3) = VDMFAC(3)
8013       VDMQ2F(4) = VDMFAC(4)
8014
8015 C  output of parameter set
8016 C *** Commented by Chiara
8017 C      IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
8018 C        WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
8019 C     &                       ' -------------------------'
8020 C        WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8021 C     &  '  ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
8022 C     &  B0POM
8023 C        WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8024 C     &  '  ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
8025 C     &  B0REG
8026 C        WRITE(LO,'(4(A,F7.3))')
8027 C     &  '  GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
8028 C        WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
8029 C        WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
8030 C        WRITE(LO,'(A,F8.3)')  '  B0HAR:',B0HAR
8031 C        WRITE(LO,'(A,F8.3)')  '  AKFAC:',AKFAC
8032 C        WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
8033 C        WRITE(LO,'(A,3F8.3)') '  RMASS:',RMASS,VAR
8034 C      ENDIF
8035
8036       CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
8037
8038       END
8039
8040 CDECK  ID>, PHO_BORNCS
8041       SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
8042 C*********************************************************************
8043 C
8044 C     calculation of Born graph cross sections and slopes
8045 C
8046 C     input: IP               particle combination
8047 C            IFHARD           -1 calculate hard Born graph cross section
8048 C                             0  take hard Born graph cross section
8049 C                                from interpolation table if available
8050 C                             1  assume that correct hard cross
8051 C                                sections are already stored in /POSBRN/
8052 C            XM1,XM2,XM3,XM4  masses of external lines
8053 C                   /GLOCMS/  energy and PT cut-off
8054 C                   /POPREG/  soft and hard parameters
8055 C                   /POSBRN/  input cross sections
8056 C                   /POZBRN/  scaled input values
8057 C                    IFHARD   0  calculate hard input cross sections
8058 C                             1  assume hard input cross sections exist
8059 C
8060 C     output: ZPOM            scaled pomeron cross section
8061 C             ZIGR            scaled reggeon cross section
8062 C             ZIGHR           scaled hard resolved cross section
8063 C             ZIGHD           scaled hard direct cross section
8064 C             ZIGT1           scaled triple-Pomeron cross section
8065 C             ZIGT2           scaled triple-Pomeron cross section
8066 C             ZIGL            scaled loop-Pomeron cross section
8067 C
8068 C*********************************************************************
8069       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8070       SAVE
8071
8072       PARAMETER(ITWO=2,
8073      &        ITHREE=3,
8074      &         IFOUR=4,
8075      &         IFIVE=5,
8076      &          FIVE=5.D0,
8077      &         THOUS=1.D3,
8078      &           EPS=0.01D0,
8079      &          DEPS=1.D-30)
8080
8081 C  input/output channels
8082       INTEGER LI,LO
8083       COMMON /POINOU/ LI,LO
8084 C  some constants
8085       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
8086       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
8087      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
8088 C  event debugging information
8089       INTEGER NMAXD
8090       PARAMETER (NMAXD=100)
8091       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8092      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8093       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8094      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8095 C  model switches and parameters
8096       CHARACTER*8 MDLNA
8097       INTEGER ISWMDL,IPAMDL
8098       DOUBLE PRECISION PARMDL
8099       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8100 C  names of hard scattering processes
8101       INTEGER Max_pro_1
8102       PARAMETER ( Max_pro_1 = 16 )
8103       CHARACTER*18 PROC
8104       COMMON /POHPRO/ PROC(0:Max_pro_1)
8105 C  hard cross sections and MC selection weights
8106       INTEGER Max_pro_2
8107       PARAMETER ( Max_pro_2 = 16 )
8108       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
8109      &  MH_acc_1,MH_acc_2
8110       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
8111       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
8112      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
8113      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
8114      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
8115      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
8116 C  interpolation tables for hard cross section and MC selection weights
8117       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
8118       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
8119       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
8120       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
8121      &  HQ2a_tab,HQ2b_tab,HEcm_tab
8122       COMMON /POHTAB/
8123      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8124      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8125      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8126      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8127      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
8128      &  HEcm_tab(1:Max_tab_E,0:4),
8129      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
8130 C  Born graph cross sections and slopes
8131       INTEGER Max_pro_3
8132       PARAMETER ( Max_pro_3 = 16 )
8133       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8134      &                SIGD1,SIGD2,DSIGH
8135       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8136      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8137 C  scaled cross sections and slopes
8138       COMPLEX*16      ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8139      &                ZIGD1,ZIGD2,
8140      &                BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8141       COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8142      &                ZIGDP(4),ZIGD1(2),ZIGD2(2),
8143      &                BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8144      &                BD1(2),BD2(2)
8145 C  Reggeon phenomenology parameters
8146       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8147      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8148       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8149      &                ALREG,ALREGP,GR(2),B0REG(2),
8150      &                GPPP,GPPR,B0PPP,B0PPR,
8151      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8152 C  parameters of 2x2 channel model
8153       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8154       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8155 C  data of c.m. system of Pomeron / Reggeon exchange
8156       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8157       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8158      &                 SIDP,CODP,SIFP,COFP
8159       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8160      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
8161      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
8162 C  obsolete cut-off information
8163       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
8164       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
8165 C  data needed for soft-pt calculation
8166       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
8167       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
8168
8169       COMPLEX*16      CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
8170      &                BPOM1,BPOM2,BREG1,BREG2,B0HARD
8171       DIMENSION       SCB1(4),SCB2(4),SCG1(4),SCG2(4)
8172       DIMENSION       BT14(2),BT24(2),BD4(4)
8173       DIMENSION       DSPT(0:Max_pro_2)
8174
8175       DATA  XMPOM / 0.766D0 /
8176       DATA  CZERO /(0.D0,0.D0)/
8177
8178       CDABS(SS) = ABS(SS)
8179       DCMPLX(X,Y) = CMPLX(X,Y)
8180
8181 C  debug output
8182       IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
8183      &  'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
8184 C  scales
8185       CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
8186 C
8187 C  calculate hard input cross sections (output in mb)
8188       IF(IFHARD.NE.1) THEN
8189         IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
8190 C  double-log interpolation
8191           CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
8192           DO 60 M=0,Max_pro_2
8193             DSIGH(M) = HSig(M)
8194             DSPT(M)  = Hdpt(M)
8195  60       CONTINUE
8196         ELSE
8197 C  new calculation
8198           CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
8199           CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
8200         ENDIF
8201 C
8202 C  save values to calculate soft pt distribution
8203         IF(IP.EQ.1) THEN
8204           VDMQ2F(1) = VDMFAC(1)
8205           VDMQ2F(2) = VDMFAC(2)
8206           VDMQ2F(3) = VDMFAC(3)
8207           VDMQ2F(4) = VDMFAC(4)
8208         ELSE IF(IP.EQ.2) THEN
8209           VDMQ2F(1) = VDMFAC(1)
8210           VDMQ2F(2) = VDMFAC(2)
8211           VDMQ2F(3) = 1.D0
8212           VDMQ2F(4) = 0.D0
8213         ELSE IF(IP.EQ.3) THEN
8214           VDMQ2F(1) = VDMFAC(3)
8215           VDMQ2F(2) = VDMFAC(4)
8216           VDMQ2F(3) = 1.D0
8217           VDMQ2F(4) = 0.D0
8218         ELSE
8219           VDMQ2F(1) = 1.D0
8220           VDMQ2F(2) = 0.D0
8221           VDMQ2F(3) = 1.D0
8222           VDMQ2F(4) = 0.D0
8223         ENDIF
8224 C  VDM factors
8225         AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
8226         AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
8227         AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
8228         AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
8229         ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
8230      &             +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
8231         ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
8232         ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
8233         ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
8234         VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
8235      &        +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
8236         DSIGHP = DSPT(9)/VFAC
8237         SIGH   = DSIGH(9)/VFAC
8238 C  extract real part
8239         IF(IPAMDL(1).EQ.0) THEN
8240           DO 50 I=0,Max_pro_2
8241             DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
8242  50       CONTINUE
8243         ENDIF
8244 C  write out results
8245         IF(IDEB(48).GE.15) THEN
8246           WRITE(LO,'(/1X,A,1P,2E11.3)')
8247      &       'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
8248           DO 200 I=0,Max_pro_2
8249             WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
8250  200      CONTINUE
8251         ENDIF
8252       ENDIF
8253
8254 C  DPMJET interface: subtract anomalous part
8255       IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
8256      &  DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
8257
8258       SCALE = CDABS(DSIGH(15))
8259       IF(SCALE.LT.DEPS) THEN
8260         SIGHD=CZERO
8261       ELSE
8262         SIGHD=DSIGH(15)
8263       ENDIF
8264       SCALE = CDABS(DSIGH(9))
8265       IF(SCALE.LT.DEPS) THEN
8266         SIGHR=CZERO
8267       ELSE
8268         SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
8269       ENDIF
8270
8271 C  calculate soft input cross sections (output in mb)
8272       SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
8273       IF(IPAMDL(1).EQ.1) THEN
8274 C  pomeron signature
8275         SP=SS*DCMPLX(0.D0,-1.D0)
8276 C  reggeon signature
8277         SR=SS*DCMPLX(0.D0,1.D0)
8278       ELSE
8279         SP=SS
8280         SR=SS
8281       ENDIF
8282 C  coupling constants (mb**1/2)
8283 C  particle dependent slopes (GeV**-2)
8284       IF(IP.EQ.1) THEN
8285         GP1 = GP(1)
8286         GP2 = GP(2)
8287         GR1 = GR(1)
8288         GR2 = GR(2)
8289         B0POM1 = B0POM(1)
8290         B0POM2 = B0POM(2)
8291         B0REG1 = B0REG(1)
8292         B0REG2 = B0REG(2)
8293         B0HARD = B0HAR
8294         RMASS1 = RMASS(1)
8295         RMASS2 = RMASS(2)
8296       ELSE IF(IP.EQ.2) THEN
8297         GP1 = GP(1)
8298         GP2 = PARMDL(77)
8299         GR1 = GR(1)
8300         GR2 = PARMDL(77)*GPPR/GPPP
8301         B0POM1 = B0POM(1)
8302         B0POM2 = B0PPP
8303         B0REG1 = B0REG(1)
8304         B0REG2 = B0PPR
8305         B0HARD = B0POM1+B0POM2
8306         RMASS1 = RMASS(1)
8307         RMASS2 = XMPOM
8308       ELSE IF(IP.EQ.3) THEN
8309         GP1 = GP(2)
8310         GP2 = PARMDL(77)
8311         GR1 = GR(2)
8312         GR2 = PARMDL(77)*GPPR/GPPP
8313         B0POM1 = B0POM(2)
8314         B0POM2 = B0PPP
8315         B0REG1 = B0REG(2)
8316         B0REG2 = B0PPR
8317         B0HARD = B0POM1+B0POM2
8318         RMASS1 = RMASS(2)
8319         RMASS2 = XMPOM
8320       ELSE IF(IP.EQ.4) THEN
8321         GP1 = PARMDL(77)
8322         GP2 = GP1
8323         GR1 = PARMDL(77)*GPPR/GPPP
8324         GR2 = GR1
8325         B0POM1 = B0PPP
8326         B0POM2 = B0PPP
8327         B0REG1 = B0PPR
8328         B0REG2 = B0PPR
8329         B0HARD = B0POM1+B0POM2
8330         RMASS1 = XMPOM
8331         RMASS2 = XMPOM
8332       ELSE
8333         WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
8334         CALL PHO_ABORT
8335       ENDIF
8336       GP1 = GP1*SCALE1
8337       GP2 = GP2*SCALE2
8338       GR1 = GR1*SCALE1
8339       GR2 = GR2*SCALE2
8340 C  input slope parameters (GeV**-2)
8341       BPOM1 = B0POM1*SCALB1
8342       BPOM2 = B0POM2*SCALB2
8343       BREG1 = B0REG1*SCALB1
8344       BREG2 = B0REG2*SCALB2
8345 C  effective slopes
8346       XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
8347       SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
8348       BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
8349       BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
8350       IF(IPAMDL(9).EQ.0) THEN
8351         BHAR = B0HARD
8352         BHAD = B0HARD
8353       ELSE IF(IPAMDL(9).EQ.1) THEN
8354         BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
8355         BHAD = BHAR
8356       ELSE IF(IPAMDL(9).EQ.2) THEN
8357         BHAR = BPOM1+BPOM2
8358         BHAD = BHAR
8359       ELSE
8360         BHAR = BPOM
8361         BHAD = BPOM
8362       ENDIF
8363 C  input cross section pomeron
8364       SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
8365       SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
8366 C  save value to calculate soft pt distribution
8367       SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
8368
8369 C  higher order graphs
8370       VIRT1 = PVIRTP(1)
8371       VIRT2 = PVIRTP(2)
8372 C  bare/renormalized intercept for enhanced graphs
8373       IF(IPAMDL(8).EQ.0) THEN
8374         DELTAP = ALPOM-1.D0
8375       ELSE
8376         DELTAP = PARMDL(48)-1.D0
8377       ENDIF
8378       SD = ECMP**2
8379       BP1 = 2.D0*BPOM1
8380       BP2 = 2.D0*BPOM2
8381 C  input cross section high-mass double diffraction
8382       CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
8383      &            DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
8384       SIGL = DCMPLX(SIGTR,0.D0)
8385       BLOO = DCMPLX(BTR,0.D0)
8386 C
8387 C  input cross section high mass diffraction particle 1
8388 C  first possibility
8389       CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8390      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8391       CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8392      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8393       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8394       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8395       BP1 = 2.D0*BPOM1*SCALB1
8396       BP2 = 2.D0*BPOM2*SCALB2
8397 C  input cross section high mass diffraction
8398       CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8399      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8400       SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8401       BTR1(1)  = DCMPLX(BTR,0.D0)
8402 C  second possibility:  high-low mass double diffraction
8403       CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8404      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8405       CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8406      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8407       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8408       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8409       BP1 = 2.D0*BPOM1*SCALB1
8410       BP2 = 2.D0*BPOM2*SCALB2
8411 C  input cross section high mass diffraction
8412       CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8413      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8414       SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8415       BTR1(2)  = DCMPLX(BTR,0.D0)
8416 C
8417 C  input cross section high mass diffraction particle 2
8418 C  first possibility
8419       CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8420      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8421       CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8422      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8423       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8424       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8425       BP1 = 2.D0*BPOM1*SCALB1
8426       BP2 = 2.D0*BPOM2*SCALB2
8427 C  input cross section high mass diffraction
8428       CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8429      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8430       SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8431       BTR2(1)  = DCMPLX(BTR,0.D0)
8432 C  second possibility:  high-low mass double diffraction
8433       CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8434      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8435       CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8436      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8437       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8438       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8439       BP1 = 2.D0*BPOM1*SCALB1
8440       BP2 = 2.D0*BPOM2*SCALB2
8441 C  input cross section high mass diffraction
8442       CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8443      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8444       SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8445       BTR2(2)  = DCMPLX(BTR,0.D0)
8446 C
8447 C  input cross section for loop-pomeron
8448 C  first possibility
8449       CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8450      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8451       CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8452      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8453       CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8454      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8455       CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8456      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8457       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8458       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8459       BP1 = BPOM1*SCALB1
8460       BP2 = BPOM2*SCALB2
8461       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8462      &  SIGTX,BTX)
8463       SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8464       BDP(1)   = DCMPLX(BTX,0.D0)
8465 C  second possibility
8466       CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8467      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8468       CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8469      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8470       CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8471      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8472       CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8473      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8474       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8475       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8476       BP1 = BPOM1*SCALB1
8477       BP2 = BPOM2*SCALB2
8478       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8479      &  SIGTX,BTX)
8480       SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8481       BDP(2)   = DCMPLX(BTX,0.D0)
8482 C  third possibility
8483       CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8484      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8485       CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8486      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8487       CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8488      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8489       CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8490      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8491       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8492       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8493       BP1 = BPOM1*SCALB1
8494       BP2 = BPOM2*SCALB2
8495       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8496      &  SIGTX,BTX)
8497       SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8498       BDP(3)   = DCMPLX(BTX,0.D0)
8499 C  fourth possibility
8500       CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8501      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8502       CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8503      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8504       CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8505      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8506       CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8507      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8508       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8509       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8510       BP1 = BPOM1*SCALB1
8511       BP2 = BPOM2*SCALB2
8512       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8513      &  SIGTX,BTX)
8514       SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8515       BDP(4)   = DCMPLX(BTX,0.D0)
8516 C
8517 C  input cross section for YY-iterated triple-pomeron
8518 C     .....
8519 C
8520 C  write out input cross sections
8521       IF(IDEB(48).GE.5) THEN
8522         WRITE(LO,'(2(/1X,A))')
8523      &    'Born graph input cross sections and slopes',
8524      &    '------------------------------------------'
8525         WRITE(LO,'(1X,A,3E12.3)') 'energy                  ',ECMP,PVIRTP
8526         WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
8527      &       XM1,XM2,XM3,XM4
8528         WRITE(LO,'(A)') ' input cross sections (millibarn):'
8529         WRITE(LO,'(A,2E12.3)') '           SIGR     ',SIGR
8530         WRITE(LO,'(A,2E12.3)') ' (soft)    SIGP     ',SIGP
8531         WRITE(LO,'(A,2E12.3)') ' (hard)    SIGHR    ',SIGHR
8532         WRITE(LO,'(A,2E12.3)') '           SIGHD    ',SIGHD
8533         WRITE(LO,'(A,4E12.3)') '           SIGT1    ',SIGT1
8534         WRITE(LO,'(A,4E12.3)') '           SIGT2    ',SIGT2
8535         WRITE(LO,'(A,2E12.3)') '           SIGL     ',SIGL
8536         WRITE(LO,'(A,4E12.3)') '         SIGDP(1-2) ',SIGDP(1),SIGDP(2)
8537         WRITE(LO,'(A,4E12.3)') '         SIGDP(3-4) ',SIGDP(3),SIGDP(4)
8538         WRITE(LO,'(A)') ' input slopes (GeV**-2)'
8539         WRITE(LO,'(A,2E12.3)') '           BREG     ',BREG
8540         WRITE(LO,'(A,2E12.3)') '            BREG1   ',BREG1
8541         WRITE(LO,'(A,2E12.3)') '            BREG2   ',BREG2
8542         WRITE(LO,'(A,2E12.3)') '           BPOM     ',BPOM
8543         WRITE(LO,'(A,2E12.3)') '            BPOM1   ',BPOM1
8544         WRITE(LO,'(A,2E12.3)') '            BPOM2   ',BPOM2
8545         WRITE(LO,'(A,2E12.3)') '           BHAR     ',BHAR
8546         WRITE(LO,'(A,2E12.3)') '           BHAD     ',BHAD
8547         WRITE(LO,'(A,E12.3)')  '           B0PPP    ',B0PPP
8548         WRITE(LO,'(A,4E12.3)') '           BTR1     ',BTR1
8549         WRITE(LO,'(A,4E12.3)') '           BTR2     ',BTR2
8550         WRITE(LO,'(A,2E12.3)') '           BLOO     ',BLOO
8551         WRITE(LO,'(A,4E12.3)') '           BDP(1-2) ',BDP(1),BDP(2)
8552         WRITE(LO,'(A,4E12.3)') '           BDP(3-4) ',BDP(3),BDP(4)
8553       ENDIF
8554 C
8555       BPOM  = BPOM*GEV2MB
8556       BREG  = BREG*GEV2MB
8557       BHAR  = BHAR*GEV2MB
8558       BHAD  = BHAD*GEV2MB
8559       BTR1(1)  = BTR1(1)*GEV2MB
8560       BTR1(2)  = BTR1(2)*GEV2MB
8561       BTR2(1)  = BTR2(1)*GEV2MB
8562       BTR2(2)  = BTR2(2)*GEV2MB
8563       BLOO  = BLOO*GEV2MB
8564 C
8565       BP4 =BPOM*4.D0
8566       BR4 =BREG*4.D0
8567       BHR4=BHAR*4.D0
8568       BHD4=BHAD*4.D0
8569       BT14(1)=BTR1(1)*4.D0
8570       BT14(2)=BTR1(2)*4.D0
8571       BT24(1)=BTR2(1)*4.D0
8572       BT24(2)=BTR2(2)*4.D0
8573       BL4 =BLOO*4.D0
8574 C
8575       ZIGP     = SIGP/(PI2*BP4)
8576       ZIGR     = SIGR/(PI2*BR4)
8577       ZIGHR    = SIGHR/(PI2*BHR4)
8578       ZIGHD    = SIGHD/(PI2*BHD4)
8579       ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
8580       ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
8581       ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
8582       ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
8583       ZIGL = SIGL/(PI2*BL4)
8584       DO 20 I=1,4
8585         BDP(I) = BDP(I)*GEV2MB
8586         BD4(I) = BDP(I)*4.D0
8587         ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
8588  20   CONTINUE
8589 C
8590       IF(IDEB(48).GE.10) THEN
8591         WRITE(LO,'(A)') ' normalized input values:'
8592         WRITE(LO,'(A,2E12.3)') '           ZIGR ',ZIGR
8593         WRITE(LO,'(A,2E12.3)') '           BREG ',BREG
8594         WRITE(LO,'(A,2E12.3)') '           ZIGP ',ZIGP
8595         WRITE(LO,'(A,2E12.3)') '           BPOM ',BPOM
8596         WRITE(LO,'(A,2E12.3)') '          ZIGHR ',ZIGHR
8597         WRITE(LO,'(A,2E12.3)') '           BHAR ',BHAR
8598         WRITE(LO,'(A,2E12.3)') '          ZIGHD ',ZIGHD
8599         WRITE(LO,'(A,2E12.3)') '           BHAD ',BHAD
8600         WRITE(LO,'(A,4E12.3)') '          ZIGT1 ',ZIGT1
8601         WRITE(LO,'(A,4E12.3)') '          ZIGT2 ',ZIGT2
8602         WRITE(LO,'(A,2E12.3)') '           ZIGL ',ZIGL
8603         WRITE(LO,'(A,4E12.3)') '     ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
8604         WRITE(LO,'(A,4E12.3)') '     ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
8605       ENDIF
8606       END
8607
8608 CDECK  ID>, PHO_SCALES
8609       SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
8610 C**********************************************************************
8611 C
8612 C     calculation of scale factors
8613 C              (mass dependent couplings and slopes)
8614 C
8615 C     input:   XM1..XM4     external masses
8616 C
8617 C     output:  SCG1,SCG2    scales of coupling constants
8618 C              SCB1,SCB2    scales of coupling slope parameter
8619 C
8620 C*********************************************************************
8621       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8622       SAVE
8623
8624       PARAMETER ( EPS  = 1.D-3 )
8625
8626 C  input/output channels
8627       INTEGER LI,LO
8628       COMMON /POINOU/ LI,LO
8629 C  event debugging information
8630       INTEGER NMAXD
8631       PARAMETER (NMAXD=100)
8632       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8633      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8634       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8635      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8636 C  Reggeon phenomenology parameters
8637       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8638      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8639       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8640      &                ALREG,ALREGP,GR(2),B0REG(2),
8641      &                GPPP,GPPR,B0PPP,B0PPR,
8642      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8643 C  parameters of 2x2 channel model
8644       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8645       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8646 C  data of c.m. system of Pomeron / Reggeon exchange
8647       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8648       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8649      &                 SIDP,CODP,SIFP,COFP
8650       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8651      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
8652      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
8653 C  model switches and parameters
8654       CHARACTER*8 MDLNA
8655       INTEGER ISWMDL,IPAMDL
8656       DOUBLE PRECISION PARMDL
8657       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8658
8659 C  scale factors for couplings
8660       ECMMIN = 2.D0
8661 *     ECMTP = 6.D0
8662       ECMTP = 1.D0
8663       IF(ABS(XM1-XM3).GT.EPS) THEN
8664         IF(ECMP.LT.ECMTP) THEN
8665           SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8666         ELSE
8667           SCG1 = PHISUP(1)
8668         ENDIF
8669       ELSE
8670         SCG1 = 1.D0
8671       ENDIF
8672       IF(ABS(XM2-XM4).GT.EPS) THEN
8673         IF(ECMP.LT.ECMTP) THEN
8674           SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8675         ELSE
8676           SCG2 = PHISUP(2)
8677         ENDIF
8678       ELSE
8679         SCG2 = 1.D0
8680       ENDIF
8681 C
8682 C  scale factors for slope parameters
8683       IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
8684         SCB1 = 1.D0
8685         SCB2 = 1.D0
8686       ELSE IF(ISWMDL(1).EQ.2) THEN
8687 C  rational
8688         SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
8689         SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
8690       ELSE IF(ISWMDL(1).GE.3) THEN
8691 C  symmetric gaussian
8692         SCB1 = VAR*(XM1-XM3)**2
8693         IF(SCB1.LT.25.D0) THEN
8694           SCB1 = EXP(-SCB1)
8695         ELSE
8696           SCB1 = 0.D0
8697         ENDIF
8698         SCB2 = VAR*(XM2-XM4)**2
8699         IF(SCB2.LT.25.D0) THEN
8700           SCB2 = EXP(-SCB2)
8701         ELSE
8702           SCB2 = 0.D0
8703         ENDIF
8704       ELSE
8705         WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
8706      &    ISWMDL(1)
8707         CALL PHO_ABORT
8708       ENDIF
8709 C  debug output
8710       IF(IDEB(65).GE.10) THEN
8711         WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
8712      &       XM1,XM2,XM3,XM4
8713         WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
8714      &       SCB1,SCB2,SCG1,SCG2
8715       ENDIF
8716       END
8717
8718 CDECK  ID>, PHO_EIKON
8719       SUBROUTINE PHO_EIKON(IP,IFHARD,B)
8720 C*********************************************************************
8721 C
8722 C     calculation of unitarized amplitudes
8723 C
8724 C     input: IP               particle combination
8725 C            IFHARD           -1  ignore previously calculated Born
8726 C                                 cross sections
8727 C                             0   calculate hard Born cross sections or
8728 C                                 take them from interpolation table
8729 C                                 (if available)
8730 C                             1   take hard cross sections from /POSBRN/
8731 C            B                impact parameter (mb**(1/2))
8732 C                   /POSBRN/  input cross sections
8733 C                   /GLOCMS/  cm energy
8734 C                   /POPREG/  soft and hard parameters
8735 C
8736 C     output: /POINT4/
8737 C             AMPEL           purely elastic amplitude
8738 C             AMPVM           quasi-elastically vectormeson prod.
8739 C             AMLMSD(2)       amplitudes of low mass sing. diffr.
8740 C             AMHMSD(2)       amplitudes of high mass sing. diffr.
8741 C             AMLMDD          amplitude of low mass double diffr.
8742 C             AMHMDD          amplitude of high mass double diffr.
8743 C
8744 C*********************************************************************
8745       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8746       SAVE
8747
8748       PARAMETER(ITWO=2,
8749      &        ITHREE=3,
8750      &         IFOUR=4,
8751      &         IFIVE=5,
8752      &          ISIX=6,
8753      &          FIVE=5.D0,
8754      &         THOUS=1.D3,
8755      &        EXPMAX=70.D0,
8756      &          DEPS=1.D-20)
8757
8758 C  input/output channels
8759       INTEGER LI,LO
8760       COMMON /POINOU/ LI,LO
8761 C  event debugging information
8762       INTEGER NMAXD
8763       PARAMETER (NMAXD=100)
8764       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8765      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8766       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8767      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8768 C  complex Born graph amplitudes used for unitarization
8769       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
8770      &                AMHMDD,AMPDP
8771       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
8772      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
8773 C  cross sections
8774       INTEGER IPFIL,IFAFIL,IFBFIL
8775       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
8776      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
8777      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
8778      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
8779      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
8780       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
8781      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
8782      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
8783      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
8784      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
8785      &                IPFIL,IFAFIL,IFBFIL
8786 C  Born graph cross sections and slopes
8787       INTEGER Max_pro_3
8788       PARAMETER ( Max_pro_3 = 16 )
8789       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8790      &                SIGD1,SIGD2,DSIGH
8791       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8792      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8793 C  scaled cross sections and slopes
8794       COMPLEX*16      ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8795      &                ZIGD1,ZIGD2,
8796      &                BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8797       COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8798      &                ZIGDP(4),ZIGD1(2),ZIGD2(2),
8799      &                BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8800      &                BD1(2),BD2(2)
8801 C  Born graph cross sections after applying diffraction model
8802       DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
8803      &                 SBOLPO,SBODPO
8804       COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
8805      &                SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
8806      &                SBODPO(0:4,4)
8807 C  global event kinematics and particle IDs
8808       INTEGER IFPAP,IFPAB
8809       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
8810       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
8811 C  data of c.m. system of Pomeron / Reggeon exchange
8812       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8813       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8814      &                 SIDP,CODP,SIFP,COFP
8815       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8816      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
8817      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
8818 C  Reggeon phenomenology parameters
8819       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8820      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8821       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8822      &                ALREG,ALREGP,GR(2),B0REG(2),
8823      &                GPPP,GPPR,B0PPP,B0PPR,
8824      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8825 C  parameters of 2x2 channel model
8826       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8827       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8828 C  model switches and parameters
8829       CHARACTER*8 MDLNA
8830       INTEGER ISWMDL,IPAMDL
8831       DOUBLE PRECISION PARMDL
8832       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8833 C  unitarized amplitudes for different diffraction channels
8834       DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
8835      &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
8836      &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
8837      &                 ZXL,BXL
8838       COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
8839      &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
8840      &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
8841      &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
8842      &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
8843      &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
8844      &                ZXL(4,4),BXL(4,4)
8845
8846       COMPLEX*16      CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
8847      &                AUXL,AMPR,AMPO,AMPP,AMPQ
8848
8849       DIMENSION PVOLD(2)
8850
8851       DATA  ELAST / 0.D0 /
8852       DATA  IPOLD / -1 /
8853       DATA  PVOLD / -1.D0, -1.D0 /
8854       DATA  XMPOM / 0.766D0 /
8855       DATA  XMVDM / 0.766D0 /
8856
8857       DCMPLX(X,Y) = CMPLX(X,Y)
8858
8859 C  calculation of scaled cross sections and slopes
8860
8861 C  test for redundant calculation
8862       IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
8863      &   .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
8864 C  effective particle masses, VDM assumption
8865         XMASS1 = PMASS(1)
8866         XMASS2 = PMASS(2)
8867         RMASS1 = RMASS(1)
8868         RMASS2 = RMASS(2)
8869         IF(IFPAP(1).EQ.22) THEN
8870           XMASS1 = XMVDM
8871         ELSE IF(IFPAP(1).EQ.990) THEN
8872           XMASS1 = XMPOM
8873         ENDIF
8874         IF(IFPAP(2).EQ.22) THEN
8875           XMASS2 = XMVDM
8876         ELSE IF(IFPAP(2).EQ.990) THEN
8877           XMASS2 = XMPOM
8878         ENDIF
8879 C  different particle combinations
8880         IF(IP.EQ.3) THEN
8881           XMASS1 = XMASS2
8882           RMASS1 = RMASS2
8883         ELSE IF(IP.EQ.4) THEN
8884           XMASS1 = XMPOM
8885           RMASS1 = XMASS1
8886         ENDIF
8887         IF(IP.GT.1) THEN
8888           XMASS2 = XMPOM
8889           RMASS2 = XMASS2
8890         ENDIF
8891 C  update pomeron CM system
8892         PMASSP(1) = XMASS1
8893         PMASSP(2) = XMASS2
8894         ECMP = ECM
8895
8896         CZERO    = DCMPLX(0.D0,0.D0)
8897         CONE     = DCMPLX(1.D0,0.D0)
8898         ELAST    = ECM
8899         PVOLD(1) = PVIRT(1)
8900         PVOLD(2) = PVIRT(2)
8901         IPOLD    = IP
8902
8903 C  purely elastic scattering
8904         CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
8905           ZXP(1,1) = ZIGP
8906           BXP(1,1) = BPOM
8907           ZXR(1,1) = ZIGR
8908           BXR(1,1) = BREG
8909           ZXH(1,1) = ZIGHR
8910           BXH(1,1) = BHAR
8911           ZXD(1,1) = ZIGHD
8912           BXD(1,1) = BHAD
8913           ZXT1A(1,1) = ZIGT1(1)
8914           BXT1A(1,1) = BTR1(1)
8915           ZXT1B(1,1) = ZIGT1(2)
8916           BXT1B(1,1) = BTR1(2)
8917           ZXT2A(1,1) = ZIGT2(1)
8918           BXT2A(1,1) = BTR2(1)
8919           ZXT2B(1,1) = ZIGT2(2)
8920           BXT2B(1,1) = BTR2(2)
8921           ZXL(1,1) = ZIGL
8922           BXL(1,1) = BLOO
8923           ZXDPE(1,1) = ZIGDP(1)
8924           BXDPE(1,1) = BDP(1)
8925           ZXDPA(1,1) = ZIGDP(2)
8926           BXDPA(1,1) = BDP(2)
8927           ZXDPB(1,1) = ZIGDP(3)
8928           BXDPB(1,1) = BDP(3)
8929           ZXDPD(1,1) = ZIGDP(4)
8930           BXDPD(1,1) = BDP(4)
8931           SBOPOM(1) = SIGP
8932           SBOREG(1) = SIGR
8933           SBOHAR(1) = SIGHR
8934           SBOHAD(1) = SIGHD
8935           SBOTR1(1,1) = SIGT1(1)
8936           SBOTR1(1,2) = SIGT1(2)
8937           SBOTR2(1,1) = SIGT2(1)
8938           SBOTR2(1,2) = SIGT2(2)
8939           SBOLPO(1) = SIGL
8940           SBODPO(1,1) = SIGDP(1)
8941           SBODPO(1,2) = SIGDP(2)
8942           SBODPO(1,3) = SIGDP(3)
8943           SBODPO(1,4) = SIGDP(4)
8944
8945 C  low mass single diffractive scattering 1
8946         CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
8947           ZXP(1,2) = ZIGP
8948           BXP(1,2) = BPOM
8949           ZXR(1,2) = ZIGR
8950           BXR(1,2) = BREG
8951           ZXH(1,2) = ZIGHR
8952           BXH(1,2) = BHAR
8953           ZXD(1,2) = ZIGHD
8954           BXD(1,2) = BHAD
8955           ZXT1A(1,2) = ZIGT1(1)
8956           BXT1A(1,2) = BTR1(1)
8957           ZXT1B(1,2) = ZIGT1(2)
8958           BXT1B(1,2) = BTR1(2)
8959           ZXT2A(1,2) = ZIGT2(1)
8960           BXT2A(1,2) = BTR2(1)
8961           ZXT2B(1,2) = ZIGT2(2)
8962           BXT2B(1,2) = BTR2(2)
8963           ZXL(1,2) = ZIGL
8964           BXL(1,2) = BLOO
8965           ZXDPE(1,2) = ZIGDP(1)
8966           BXDPE(1,2) = BDP(1)
8967           ZXDPA(1,2) = ZIGDP(2)
8968           BXDPA(1,2) = BDP(2)
8969           ZXDPB(1,2) = ZIGDP(3)
8970           BXDPB(1,2) = BDP(3)
8971           ZXDPD(1,2) = ZIGDP(4)
8972           BXDPD(1,2) = BDP(4)
8973           SBOPOM(2) = SIGP
8974           SBOREG(2) = SIGR
8975           SBOHAR(2) = SIGHR
8976           SBOHAD(2) = 0.D0
8977           SBOTR1(2,1) = SIGT1(1)
8978           SBOTR1(2,2) = SIGT1(2)
8979           SBOTR2(2,1) = SIGT2(1)
8980           SBOTR2(2,2) = SIGT2(2)
8981           SBOLPO(2) = SIGL
8982           SBODPO(2,1) = SIGDP(1)
8983           SBODPO(2,2) = SIGDP(2)
8984           SBODPO(2,3) = SIGDP(3)
8985           SBODPO(2,4) = SIGDP(4)
8986
8987 C  low mass single diffractive scattering 2
8988         CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
8989           ZXP(1,3) = ZIGP
8990           BXP(1,3) = BPOM
8991           ZXR(1,3) = ZIGR
8992           BXR(1,3) = BREG
8993           ZXH(1,3) = ZIGHR
8994           BXH(1,3) = BHAR
8995           ZXD(1,3) = ZIGHD
8996           BXD(1,3) = BHAD
8997           ZXT1A(1,3) = ZIGT1(1)
8998           BXT1A(1,3) = BTR1(1)
8999           ZXT1B(1,3) = ZIGT1(2)
9000           BXT1B(1,3) = BTR1(2)
9001           ZXT2A(1,3) = ZIGT2(1)
9002           BXT2A(1,3) = BTR2(1)
9003           ZXT2B(1,3) = ZIGT2(2)
9004           BXT2B(1,3) = BTR2(2)
9005           ZXL(1,3) = ZIGL
9006           BXL(1,3) = BLOO
9007           ZXDPE(1,3) = ZIGDP(1)
9008           BXDPE(1,3) = BDP(1)
9009           ZXDPA(1,3) = ZIGDP(2)
9010           BXDPA(1,3) = BDP(2)
9011           ZXDPB(1,3) = ZIGDP(3)
9012           BXDPB(1,3) = BDP(3)
9013           ZXDPD(1,3) = ZIGDP(4)
9014           BXDPD(1,3) = BDP(4)
9015           SBOPOM(3) = SIGP
9016           SBOREG(3) = SIGR
9017           SBOHAR(3) = SIGHR
9018           SBOHAD(3) = 0.D0
9019           SBOTR1(3,1) = SIGT1(1)
9020           SBOTR1(3,2) = SIGT1(2)
9021           SBOTR2(3,1) = SIGT2(1)
9022           SBOTR2(3,2) = SIGT2(2)
9023           SBOLPO(3) = SIGL
9024           SBODPO(3,1) = SIGDP(1)
9025           SBODPO(3,2) = SIGDP(2)
9026           SBODPO(3,3) = SIGDP(3)
9027           SBODPO(3,4) = SIGDP(4)
9028
9029 C  low mass double diffractive scattering
9030         CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
9031           ZXP(1,4) = ZIGP
9032           BXP(1,4) = BPOM
9033           ZXR(1,4) = ZIGR
9034           BXR(1,4) = BREG
9035           ZXH(1,4) = ZIGHR
9036           BXH(1,4) = BHAR
9037           ZXD(1,4) = ZIGHD
9038           BXD(1,4) = BHAD
9039           ZXT1A(1,4) = ZIGT1(1)
9040           BXT1A(1,4) = BTR1(1)
9041           ZXT1B(1,4) = ZIGT1(2)
9042           BXT1B(1,4) = BTR1(2)
9043           ZXT2A(1,4) = ZIGT2(1)
9044           BXT2A(1,4) = BTR2(1)
9045           ZXT2B(1,4) = ZIGT2(2)
9046           BXT2B(1,4) = BTR2(2)
9047           ZXL(1,4) = ZIGL
9048           BXL(1,4) = BLOO
9049           ZXDPE(1,4) = ZIGDP(1)
9050           BXDPE(1,4) = BDP(1)
9051           ZXDPA(1,4) = ZIGDP(2)
9052           BXDPA(1,4) = BDP(2)
9053           ZXDPB(1,4) = ZIGDP(3)
9054           BXDPB(1,4) = BDP(3)
9055           ZXDPD(1,4) = ZIGDP(4)
9056           BXDPD(1,4) = BDP(4)
9057           SBOPOM(4) = SIGP
9058           SBOREG(4) = SIGR
9059           SBOHAR(4) = SIGHR
9060           SBOHAD(4) = 0.D0
9061           SBOTR1(4,1) = SIGT1(1)
9062           SBOTR1(4,2) = SIGT1(2)
9063           SBOTR2(4,1) = SIGT2(1)
9064           SBOTR2(4,2) = SIGT2(2)
9065           SBOLPO(4) = SIGL
9066           SBODPO(4,1) = SIGDP(1)
9067           SBODPO(4,2) = SIGDP(2)
9068           SBODPO(4,3) = SIGDP(3)
9069           SBODPO(4,4) = SIGDP(4)
9070
9071 C  calculate Born graph cross sections
9072         SBOPOM(0) = 0.D0
9073         SBOREG(0) = 0.D0
9074         SBOHAR(0) = 0.D0
9075         SBOHAD(0) = 0.D0
9076         SBOTR1(0,1) = 0.D0
9077         SBOTR1(0,2) = 0.D0
9078         SBOTR2(0,1) = 0.D0
9079         SBOTR2(0,2) = 0.D0
9080         SBOLPO(0) = 0.D0
9081         SBODPO(0,1) = 0.D0
9082         SBODPO(0,2) = 0.D0
9083         SBODPO(0,3) = 0.D0
9084         SBODPO(0,4) = 0.D0
9085         DO 150 I=1,4
9086           SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
9087           SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
9088           SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
9089           SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
9090           SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
9091           SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
9092           SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
9093           SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
9094           SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
9095           SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
9096           SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
9097           SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
9098           SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
9099  150    CONTINUE
9100
9101         SIGPOM = SBOPOM(0)
9102         SIGREG = SBOREG(0)
9103         SIGTR1(1) = SBOTR1(0,1)
9104         SIGTR1(2) = SBOTR1(0,2)
9105         SIGTR2(1) = SBOTR2(0,1)
9106         SIGTR2(2) = SBOTR2(0,2)
9107         SIGLOO = SBOLPO(0)
9108         SIGDPO(1) = SBODPO(0,1)
9109         SIGDPO(2) = SBODPO(0,2)
9110         SIGDPO(3) = SBODPO(0,3)
9111         SIGDPO(4) = SBODPO(0,4)
9112         SIGHAR = SBOHAR(0)
9113         SIGDIR = SBOHAD(0)
9114       ENDIF
9115
9116       B24=DCMPLX(B**2,0.D0)/4.D0
9117
9118       AMPEL     = CZERO
9119       AMPR      = CZERO
9120       AMPO      = CZERO
9121       AMPP      = CZERO
9122       AMPQ      = CZERO
9123       AMLMSD(1) = CZERO
9124       AMLMSD(2) = CZERO
9125       AMHMSD(1) = CZERO
9126       AMHMSD(2) = CZERO
9127       AMLMDD    = CZERO
9128       AMHMDD    = CZERO
9129
9130 C  different models
9131
9132       IF(ISWMDL(1).LT.3) THEN
9133 C  pomeron
9134         AUXP  = ZXP(1,1)*EXP(-B24/BXP(1,1))
9135 C  reggeon
9136         AUXR  = ZXR(1,1)*EXP(-B24/BXR(1,1))
9137 C  hard resolved processes
9138         AUXH  = ZXH(1,1)*EXP(-B24/BXH(1,1))
9139 C  hard direct processes
9140         AUXD  = ZXD(1,1)*EXP(-B24/BXD(1,1))
9141 C  triple-Pomeron: baryon high mass diffraction
9142         AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
9143      &        + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
9144 C  triple-Pomeron: photon/meson high mass diffraction
9145         AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
9146      &        + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
9147 C  loop-Pomeron
9148         AUXL  = ZXL(1,1)*EXP(-B24/BXL(1,1))
9149       ENDIF
9150
9151       IF(ISWMDL(1).EQ.0) THEN
9152         AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
9153      &                 *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
9154      &        +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
9155      &               )
9156         AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
9157      &                                      +AUXT1+AUXT2+AUXL))
9158         AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
9159      &                                      +AUXT1+AUXT2+AUXL))
9160         AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
9161      &                                      +AUXT1+AUXT2+AUXL))
9162         AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
9163      &                                      +AUXT1+AUXT2+AUXL))
9164
9165       ELSE IF(ISWMDL(1).EQ.1) THEN
9166         AMPR = 0.5D0*SQRT(VDMQ2F(1))*
9167      &         ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
9168         AMPO = 0.5D0*SQRT(VDMQ2F(2))*
9169      &         ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
9170         AMPP = 0.5D0*SQRT(VDMQ2F(3))*
9171      &         ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
9172         AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
9173      &         ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
9174         AMPEL = SQRT(VDMQ2F(1))*AMPR
9175      &         + SQRT(VDMQ2F(2))*AMPO
9176      &         + SQRT(VDMQ2F(3))*AMPP
9177      &         + SQRT(VDMQ2F(4))*AMPQ
9178      &         + AUXD/2.D0
9179
9180 C  simple analytic two channel model (version A)
9181       ELSE IF(ISWMDL(1).EQ.3) THEN
9182         CALL PHO_CHAN2A(B)
9183
9184       ELSE
9185         WRITE(LO,'(1X,A,I2)')
9186      &       'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
9187         STOP
9188       ENDIF
9189
9190       END
9191
9192 CDECK  ID>, PHO_DSIGDT
9193       SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
9194 C*********************************************************************
9195 C
9196 C     calculation of unitarized amplitude
9197 C                    and differential cross section
9198 C
9199 C     input:   EE       cm energy (GeV)
9200 C              XTA(1,*) t values (GeV**2)
9201 C              NFILL    entries in t table
9202 C
9203 C     output:  XTA(2,*)  DSIG/DT  g p --> g h/V (mub/GeV**2)
9204 C              XTA(3,*)  DSIG/DT  g p --> rho0 h/V
9205 C              XTA(4,*)  DSIG/DT  g p --> omega0 h/V
9206 C              XTA(5,*)  DSIG/DT  g p --> phi h/V
9207 C              XTA(6,*)  DSIG/DT  g p --> pi+ pi- h/V (continuum)
9208 C
9209 C*********************************************************************
9210       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9211       SAVE
9212
9213       PARAMETER(ITWO=2,
9214      &        ITHREE=3,
9215      &         THOUS=1.D3,
9216      &          DEPS=1.D-20)
9217
9218       DIMENSION XTA(6,NFILL)
9219
9220 C  input/output channels
9221       INTEGER LI,LO
9222       COMMON /POINOU/ LI,LO
9223 C  some constants
9224       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9225       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9226      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9227 C  integration precision for hard cross sections (obsolete)
9228       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9229       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9230 C  event debugging information
9231       INTEGER NMAXD
9232       PARAMETER (NMAXD=100)
9233       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9234      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9235       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9236      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9237 C  global event kinematics and particle IDs
9238       INTEGER IFPAP,IFPAB
9239       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9240       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9241 C  complex Born graph amplitudes used for unitarization
9242       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9243      &                AMHMDD,AMPDP
9244       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9245      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9246
9247       COMPLEX*16   XT,AMP,CZERO
9248       DIMENSION    AMP(5),XPNT(96),WGHT(96),XT(5,100)
9249       CHARACTER*12 FNA
9250
9251       CDABS(AMPEL) = ABS(AMPEL)
9252       DCMPLX(X,Y) = CMPLX(X,Y)
9253
9254       CZERO=DCMPLX(0.D0,0.D0)
9255
9256       ETMP = ECM
9257       ECM  = EE
9258
9259       IF(NFILL.GT.100) THEN
9260         WRITE(LO,'(1X,A,I4)')
9261      &    'PHO_DSIGDT:ERROR: too many entries in table',NFILL
9262         STOP
9263       ENDIF
9264 C
9265       DO 100 K=1,NFILL
9266         DO 150 L=1,5
9267           XT(L,K)=CZERO
9268  150    CONTINUE
9269  100  CONTINUE
9270 C
9271 C  impact parameter integration
9272 C     BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9273       BMAX=10.D0
9274       CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9275       IAMP = 5
9276       IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
9277         I1 = 1
9278         I2 = 0
9279       ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
9280         I1 = 0
9281         I2 = 1
9282       ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
9283         I1 = 1
9284         I2 = 1
9285       ELSE
9286         I1 = 0
9287         I2 = 0
9288         IAMP = 1
9289       ENDIF
9290       J1 = I1*2
9291       K1 = I1*3
9292       L1 = I1*4
9293       J2 = I2*2
9294       K2 = I2*3
9295       L2 = I2*4
9296 C
9297       DO 200 I=1,NGAUSO
9298         WG=WGHT(I)*XPNT(I)
9299 C  calculate amplitudes
9300         IF(I.EQ.1) THEN
9301           CALL PHO_EIKON(1,-1,XPNT(I))
9302         ELSE
9303           CALL PHO_EIKON(1,1,XPNT(I))
9304         ENDIF
9305         AMP(1) = AMPEL
9306         AMP(2) = AMPVM(I1,I2)
9307         AMP(3) = AMPVM(J1,J2)
9308         AMP(4) = AMPVM(K1,K2)
9309         AMP(5) = AMPVM(L1,L2)
9310 C
9311         DO 400 J=1,NFILL
9312           XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
9313           FAC = PHO_BESSJ0(XX)*WG
9314           DO 500 K=1,IAMP
9315             XT(1,J)=XT(1,J)+AMP(K)*FAC
9316  500      CONTINUE
9317  400    CONTINUE
9318  200  CONTINUE
9319 C
9320 C  change units to mb/GeV**2
9321       FAC = 4.D0*PI/GEV2MB
9322       FNA = '(mb/GeV**2) '
9323       IF(I1+I2.EQ.1) THEN
9324         FAC = FAC*THOUS
9325         FNA = '(mub/GeV**2)'
9326       ELSE IF(I1+I2.EQ.2) THEN
9327         FAC = FAC*THOUS*THOUS
9328         FNA = '(nb/GeV**2) '
9329       ENDIF
9330       IF(IDEB(56).GE.5) THEN
9331         WRITE(LO,'(1X,A,A12,/1X,A)') 'table:  -T (GeV**2)   DSIG/DT ',
9332      &    FNA,'------------------------------------------'
9333       ENDIF
9334       DO 600 J=1,NFILL
9335         DO 700 K=1,IAMP
9336           XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
9337  700    CONTINUE
9338         IF(IDEB(56).GE.5) THEN
9339           WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
9340         ENDIF
9341  600  CONTINUE
9342
9343       ECM = ETMP
9344       END
9345
9346 CDECK  ID>, PHO_XSECT
9347       SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
9348 C*********************************************************************
9349 C
9350 C     calculation of physical cross sections
9351 C
9352 C     input:   IP      particle combination
9353 C              IFHARD  -1 reset Born graph cross section tables
9354 C                      0  calculate hard cross sections or take them
9355 C                         from interpolation table (if available)
9356 C                      1  assume that hard cross sections are already
9357 C                         calculated and stored in /POSBRN/
9358 C              EE      cms energy (GeV)
9359 C
9360 C     output:  /POSBRN/  input cross sections
9361 C              /POZBRN/  scaled input cross values
9362 C              /POCSEC/  physical cross sections and slopes
9363 C
9364 C              slopes in GeV**-2, cross sections in mb
9365 C
9366 C*********************************************************************
9367       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9368       SAVE
9369
9370       PARAMETER(ONEM=-1.D0,
9371      &         THOUS=1.D3,
9372      &          DEPS=1.D-20)
9373
9374 C  input/output channels
9375       INTEGER LI,LO
9376       COMMON /POINOU/ LI,LO
9377 C  some constants
9378       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9379       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9380      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9381 C  event debugging information
9382       INTEGER NMAXD
9383       PARAMETER (NMAXD=100)
9384       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9385      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9386       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9387      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9388 C  integration precision for hard cross sections (obsolete)
9389       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9390       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9391 C  model switches and parameters
9392       CHARACTER*8 MDLNA
9393       INTEGER ISWMDL,IPAMDL
9394       DOUBLE PRECISION PARMDL
9395       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9396 C  Born graph cross sections and slopes
9397       INTEGER Max_pro_3
9398       PARAMETER ( Max_pro_3 = 16 )
9399       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9400      &                SIGD1,SIGD2,DSIGH
9401       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9402      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9403 C  cross sections
9404       INTEGER IPFIL,IFAFIL,IFBFIL
9405       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9406      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9407      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9408      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9409      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9410       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9411      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9412      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9413      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9414      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9415      &                IPFIL,IFAFIL,IFBFIL
9416 C  global event kinematics and particle IDs
9417       INTEGER IFPAP,IFPAB
9418       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9419       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9420
9421       CHARACTER*15    PHO_PNAME
9422
9423 C  complex Born graph amplitudes used for unitarization
9424       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9425      &                AMHMDD,AMPDP
9426       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9427      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9428
9429       DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
9430       CHARACTER*8 VMESA(0:4),VMESB(0:4)
9431       DATA VMESA / 'vmeson  ','rho     ','omega   ','phi     ',
9432      &             'pi+pi-  ' /
9433       DATA VMESB / 'vmeson  ','rho     ','omega   ','phi     ',
9434      &             'pi+pi-  ' /
9435
9436       CDABS(AMPEL) = ABS(AMPEL)
9437
9438       ETMP = ECM
9439       IF(EE.LT.0.D0) GOTO 500
9440       ECM = EE
9441
9442 C  impact parameter integration
9443 C     BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9444       BMAX=10.D0
9445       CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9446       SIGTOT    = 0.D0
9447       SIGINE    = 0.D0
9448       SIGELA    = 0.D0
9449       SIGNDF    = 0.D0
9450       SIGLSD(1) = 0.D0
9451       SIGLSD(2) = 0.D0
9452       SIGLDD    = 0.D0
9453       SIGHSD(1) = 0.D0
9454       SIGHSD(2) = 0.D0
9455       SIGHDD    = 0.D0
9456       SIGCDF(0) = 0.D0
9457       SIG1SO    = 0.D0
9458       SIG1HA    = 0.D0
9459       SLEL1 = 0.D0
9460       SLEL2 = 0.D0
9461       DO 50 I=1,4
9462         SIGCDF(I) = 0.D0
9463         DO 55 K=1,4
9464           SIGVM(I,K) = 0.D0
9465           SLVM1(I,K) = 0.D0
9466           SLVM2(I,K) = 0.D0
9467  55     CONTINUE
9468  50   CONTINUE
9469
9470       DO 100 I=1,NGAUSO
9471         B2  = XPNT(I)**2
9472         WG  = WGHT(I)*XPNT(I)
9473         WGB = B2*WG
9474
9475 C  calculate impact parameter amplitude, results in /POINT4/
9476         IF(I.EQ.1) THEN
9477           CALL PHO_EIKON(IP,IFHARD,XPNT(I))
9478         ELSE
9479           CALL PHO_EIKON(IP,1,XPNT(I))
9480         ENDIF
9481
9482         SIGTOT    = SIGTOT + DREAL(AMPEL)*WG
9483         SIGELA    = SIGELA + CDABS(AMPEL)**2*WG
9484         SLEL1     = SLEL1  + AMPEL*WGB
9485         SLEL2     = SLEL2  + AMPEL*WG
9486
9487         DO 110 J=1,4
9488           DO 120 K=1,4
9489             SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
9490             SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
9491             SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
9492  120      CONTINUE
9493           SIGCDF(J)   = SIGCDF(J)   + DREAL(AMPDP(J))*WG
9494  110    CONTINUE
9495
9496         SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
9497         SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
9498         SIGLDD    = SIGLDD    + CDABS(AMLMDD)**2*WG
9499         SIG1SO    = SIG1SO    + DREAL(AMPSOF)*WG
9500         SIG1HA    = SIG1HA    + DREAL(AMPHAR)*WG
9501         SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
9502         SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
9503         SIGHDD    = SIGHDD    + DREAL(AMHMDD)*WG
9504
9505  100  CONTINUE
9506
9507       SIGDIR = DREAL(SIGHD)
9508       FAC    = 4.D0*PI2
9509       SIGTOT = SIGTOT*FAC
9510       SIGELA = SIGELA*FAC
9511       FACSL  = 0.5D0/GEV2MB
9512       SLOEL  = SLEL1/MAX(DEPS,SLEL2)*FACSL
9513
9514       IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
9515         DO 130 I=1,4
9516           DO 140 J=1,4
9517             SIGVM(I,J) = SIGVM(I,J)*FAC
9518             SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
9519  140      CONTINUE
9520  130    CONTINUE
9521         SIGVM(0,0) = 0.D0
9522         DO 150 I=1,4
9523           SIGVM(0,I) = 0.D0
9524           SIGVM(I,0) = 0.D0
9525           DO 160 J=1,4
9526             SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
9527             SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
9528  160      CONTINUE
9529           SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
9530  150    CONTINUE
9531       ENDIF
9532
9533 C  diffractive cross sections
9534
9535       SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
9536       SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
9537       SIGLDD    = SIGLDD   *FAC*PARMDL(42)
9538       SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
9539       SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
9540       SIGHDD    = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
9541      &            *FAC*PARMDL(42)
9542
9543 C  double pomeron scattering
9544
9545       SIGCDF(0) = 0.D0
9546       DO 170 I=1,4
9547         SIGCDF(I) = SIGCDF(I)*FAC
9548         SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
9549  170  CONTINUE
9550
9551       SIG1SO    = SIG1SO   *FAC
9552       SIG1HA    = SIG1HA   *FAC
9553
9554       SIGINE    = SIGTOT - SIGELA
9555
9556 C  user-forced change of diffractive cross section
9557
9558       IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
9559
9560 C  use optional explicit parametrization for single-diffraction
9561
9562         SIGSD1 = SIGLSD(1)+SIGHSD(1)
9563         SIGSD2 = SIGLSD(2)+SIGHSD(2)
9564         SS = EE*EE
9565         XI_MIN = 1.5D0/SS
9566         XI_MAX = PARMDL(45)**2
9567         CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
9568      &    SIG_SD1,SIG_SD2,SIG_DD)
9569         SIG_SD1 = SIG_SD1*PARMDL(40)
9570         SIG_SD2 = SIG_SD2*PARMDL(41)
9571
9572 **sr
9573 C       DEL_SD1 = SIG_SD1-SIGSD1
9574         DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
9575 **
9576
9577         FAC = SIGLSD(1)/SIGSD1
9578         SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
9579         SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
9580
9581 C       DEL_SD2 = SIG_SD2-SIGSD2
9582         DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
9583
9584         FAC = SIGLSD(2)/SIGSD2
9585         SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
9586         SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
9587
9588         IF(ISWMDL(30).GE.2) THEN
9589
9590 C  use explicit parametrization also for double diffraction diss.
9591           SIGDD  = SIGLDD+SIGHDD
9592           SIG_DD = SIG_DD*PARMDL(42)
9593           DEL_DD = SIG_DD-SIGDD
9594           FAC = SIGLDD/SIGDD
9595           SIGLDD = SIGLDD+FAC*DEL_DD
9596           SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
9597           SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
9598
9599         ELSE
9600
9601 C  rescale double diffraction cross sections
9602           SIGLDD    = SIGLDD   *PARMDL(42)
9603           SIGHDD    = SIGHDD   *PARMDL(42)
9604           SIGCOR = DEL_SD1 + DEL_SD2
9605      &      +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9606
9607         ENDIF
9608
9609       ELSE
9610
9611 C  rescale unitarized cross sections for diffraction dissociation
9612
9613         SIGLSD(1) = SIGLSD(1)*PARMDL(40)
9614         SIGHSD(1) = SIGHSD(1)*PARMDL(40)
9615         SIGLSD(2) = SIGLSD(2)*PARMDL(41)
9616         SIGHSD(2) = SIGHSD(2)*PARMDL(41)
9617         SIGLDD    = SIGLDD   *PARMDL(42)
9618         SIGHDD    = SIGHDD   *PARMDL(42)
9619         SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
9620      &          +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
9621      &          +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9622
9623       ENDIF
9624
9625 C  non-diffractive inelastic cross section
9626
9627       SIGNDF    = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9628      &            -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9629      &            -SIGLDD-SIGHDD
9630
9631 C  specify elastic scattering channel
9632
9633  500  CONTINUE
9634       IF(IFPAP(1).NE.22) THEN
9635         VMESA(1) = PHO_PNAME(IFPAB(1),0)
9636       ELSE
9637         VMESA(1) = 'rho           '
9638       ENDIF
9639       IF(IFPAP(2).NE.22) THEN
9640         VMESB(1) = PHO_PNAME(IFPAB(2),0)
9641       ELSE
9642         VMESB(1) = 'rho           '
9643       ENDIF
9644
9645 C  write out physical cross sections
9646
9647       IF(IDEB(57).GE.5) THEN
9648         WRITE(LO,'(/1X,A,I3,/1X,A)')
9649      &    'PHO_XSECT: cross sections (mb) for combination',IP,
9650      &    '----------------------------------------------'
9651         WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
9652         WRITE(LO,'(5X,A,E12.3)') '             total ',SIGTOT
9653         WRITE(LO,'(5X,A,E12.3)') '    purely elastic ',SIGELA
9654         WRITE(LO,'(5X,A,E12.3)') '         inelastic ',SIGINE
9655         WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
9656      &    SIGLSD(1)+SIGHSD(1)
9657         IF(IDEB(57).GE.7) THEN
9658           WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLSD(1)
9659           WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHSD(1)
9660         ENDIF
9661         WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
9662      &    SIGLSD(2)+SIGHSD(2)
9663         IF(IDEB(57).GE.7) THEN
9664           WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLSD(2)
9665           WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHSD(2)
9666         ENDIF
9667         WRITE(LO,'(5X,A,E12.3)') '       double diff ',SIGLDD+SIGHDD
9668         IF(IDEB(57).GE.7) THEN
9669           WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLDD
9670           WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHDD
9671         ENDIF
9672         WRITE(LO,'(5X,A,E12.3)') '    double pomeron ',SIGCDF(0)
9673         IF(IDEB(57).GE.7) THEN
9674           WRITE(LO,'(5X,A,E12.3)') '    purely elastic ',SIGCDF(1)
9675           WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
9676           WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
9677           WRITE(LO,'(5X,A,E12.3)') '   excitation both ',SIGCDF(4)
9678         ENDIF
9679         WRITE(LO,'(5X,A,E12.3)') '     elastic slope ',SLOEL
9680         DO 200 I=1,4
9681           DO 210 J=1,4
9682             IF(SIGVM(I,J).GT.DEPS) THEN
9683               WRITE(LO,'(1X,3A)') 'q-elastic production of ',
9684      &          VMESA(I),VMESB(J)
9685               WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
9686               IF((I.NE.0).AND.(J.NE.0))
9687      &          WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
9688             ENDIF
9689  210      CONTINUE
9690  200    CONTINUE
9691         IF(IDEB(57).GE.7) THEN
9692           WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
9693           WRITE(LO,'(5X,A,E12.3)') '  one-pomeron soft ',SIG1SO
9694           WRITE(LO,'(5X,A,E12.3)') '  one-pomeron hard ',SIG1HA
9695           WRITE(LO,'(5X,A,E12.3)') '  pomeron exchange ',SIGPOM
9696           WRITE(LO,'(5X,A,E12.3)') '  reggeon exchange ',SIGREG
9697           WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
9698           WRITE(LO,'(5X,A,E12.3/)')'   hard direct QCD ',
9699      &      DREAL(DSIGH(15))
9700         ENDIF
9701       ENDIF
9702
9703       ECM = ETMP
9704
9705       END
9706
9707 CDECK  ID>, PHO_IMPAMP
9708       SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
9709 C*********************************************************************
9710 C
9711 C     calculation of physical  impact parameter amplitude
9712 C
9713 C     input:   EE      cm energy (GeV)
9714 C              BMIN    lower bound in B
9715 C              BMAX    upper bound in B
9716 C              NSTEP   number of values (linear)
9717 C
9718 C     output:  values written to output unit
9719 C
9720 C*********************************************************************
9721       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9722       SAVE
9723
9724       PARAMETER(ONEM=-1.D0,
9725      &         THOUS=1.D3,
9726      &          DEPS=1.D-20)
9727
9728 C  input/output channels
9729       INTEGER LI,LO
9730       COMMON /POINOU/ LI,LO
9731 C  event debugging information
9732       INTEGER NMAXD
9733       PARAMETER (NMAXD=100)
9734       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9735      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9736       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9737      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9738 C  model switches and parameters
9739       CHARACTER*8 MDLNA
9740       INTEGER ISWMDL,IPAMDL
9741       DOUBLE PRECISION PARMDL
9742       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9743 C  global event kinematics and particle IDs
9744       INTEGER IFPAP,IFPAB
9745       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9746       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9747 C  complex Born graph amplitudes used for unitarization
9748       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9749      &                AMHMDD,AMPDP
9750       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9751      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9752
9753       ECM=EE
9754       BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
9755 C
9756       WRITE(LO,'(3(/,1X,A))')
9757      &  'impact parameter amplitudes:',
9758      &  '  B  AMP-EL  AMP-LMSD(1,2)  AMP-HMSD(1,2)  AMP-LMDD  AMP-HMDD',
9759      &  '-------------------------------------------------------------'
9760 C
9761       BB = BMIN
9762       DO 100 I=1,NSTEP
9763 C  calculate impact parameter amplitudes
9764         IF(I.EQ.1) THEN
9765           CALL PHO_EIKON(1,-1,BMIN)
9766         ELSE
9767           CALL PHO_EIKON(1,1,BB)
9768         ENDIF
9769         WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
9770      &    DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
9771      &    DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
9772         BB = BB+BSTEP
9773  100  CONTINUE
9774
9775       END
9776
9777 CDECK  ID>, PHO_PRBDIS
9778       SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
9779 C*********************************************************************
9780 C
9781 C     calculation of multi interactions probabilities
9782 C
9783 C     input:  IP        particle combination to scatter
9784 C             ECM       CMS energy
9785 C             IE        index for weight storing
9786 C             /PROBAB/
9787 C             IMAX      max. number of soft pomeron interactions
9788 C             KMAX      max. number of hard pomeron interactions
9789 C
9790 C     output: /PROBAB/
9791 C             PROB      field of probabilities
9792 C
9793 C*********************************************************************
9794       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9795       SAVE
9796
9797       PARAMETER ( EPS=1.D-10 )
9798
9799 C  input/output channels
9800       INTEGER LI,LO
9801       COMMON /POINOU/ LI,LO
9802 C  event debugging information
9803       INTEGER NMAXD
9804       PARAMETER (NMAXD=100)
9805       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9806      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9807       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9808      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9809 C  Reggeon phenomenology parameters
9810       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
9811      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
9812       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
9813      &                ALREG,ALREGP,GR(2),B0REG(2),
9814      &                GPPP,GPPR,B0PPP,B0PPR,
9815      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
9816 C  parameters of 2x2 channel model
9817       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
9818       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
9819 C  Born graph cross sections and slopes
9820       INTEGER Max_pro_3
9821       PARAMETER ( Max_pro_3 = 16 )
9822       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9823      &                SIGD1,SIGD2,DSIGH
9824       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9825      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9826 C  obsolete cut-off information
9827       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
9828       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
9829 C  Born graph cross sections after applying diffraction model
9830       DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
9831      &                 SBOLPO,SBODPO
9832       COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
9833      &                SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
9834      &                SBODPO(0:4,4)
9835 C  cross sections
9836       INTEGER IPFIL,IFAFIL,IFBFIL
9837       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9838      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9839      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9840      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9841      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9842       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9843      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9844      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9845      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9846      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9847      &                IPFIL,IFAFIL,IFBFIL
9848 C  cut probability distribution
9849       INTEGER IEETA1,IIMAX,KKMAX
9850       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
9851       INTEGER IEEMAX,IMAX,KMAX
9852       REAL PROB
9853       DOUBLE PRECISION EPTAB
9854       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
9855      &                IEEMAX,IMAX,KMAX
9856 C  energy-interpolation table
9857       INTEGER IEETA2
9858       PARAMETER ( IEETA2 = 20 )
9859       INTEGER ISIMAX
9860       DOUBLE PRECISION SIGTAB,SIGECM
9861       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
9862 C  average number of cut soft and hard ladders (obsolete)
9863       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
9864       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
9865 C  some constants
9866       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9867       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9868      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9869 C  integration precision for hard cross sections (obsolete)
9870       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9871       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9872 C  model switches and parameters
9873       CHARACTER*8 MDLNA
9874       INTEGER ISWMDL,IPAMDL
9875       DOUBLE PRECISION PARMDL
9876       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9877 C  unitarized amplitudes for different diffraction channels
9878       DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
9879      &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
9880      &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
9881      &                 ZXL,BXL
9882       COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
9883      &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
9884      &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
9885      &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
9886      &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
9887      &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
9888      &                ZXL(4,4),BXL(4,4)
9889
9890 C  local variables
9891       DIMENSION  AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
9892       PARAMETER (ICHMAX=40)
9893       DIMENSION CHIFAC(4,4),AMPCOF(4)
9894       DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
9895       DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
9896
9897 C  combinatorical factors
9898       DATA      CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
9899      &                   1.D0,-1.D0, 1.D0,-1.D0,
9900      &                   1.D0,-1.D0,-1.D0, 1.D0,
9901      &                   1.D0, 1.D0, 1.D0, 1.D0 /
9902
9903       DATA FACLOG /           .000000000000000D+00,
9904      &  .000000000000000D+00, .693147180559945D+00,
9905      &  .109861228866811D+01, .138629436111989D+01,
9906      &  .160943791243410D+01, .179175946922805D+01,
9907      &  .194591014905531D+01, .207944154167984D+01,
9908      &  .219722457733622D+01, .230258509299405D+01,
9909      &  .239789527279837D+01, .248490664978800D+01,
9910      &  .256494935746154D+01, .263905732961526D+01,
9911      &  .270805020110221D+01, .277258872223978D+01,
9912      &  .283321334405622D+01, .289037175789616D+01,
9913      &  .294443897916644D+01, .299573227355399D+01,
9914      &  .304452243772342D+01, .309104245335832D+01,
9915      &  .313549421592915D+01, .317805383034795D+01,
9916      &  .321887582486820D+01, .325809653802148D+01,
9917      &  .329583686600433D+01, .333220451017520D+01,
9918      &  .336729582998647D+01, .340119738166216D+01 /
9919
9920       DATA  ELAST / 0.D0 /
9921       DATA  IPLAST / 0 /
9922
9923 C  test for redundant calculation: skip cs calculation
9924       IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
9925         ELAST = ECM
9926         IPLAST = IP
9927         CALL PHO_XSECT(IP,0,ELAST)
9928         ISIMAX = IE
9929         SIGECM(IP,IE) = ECM
9930         SIGTAB(IP,1,IE) = SIGTOT
9931         SIGTAB(IP,2,IE) = SIGELA
9932         J = 2
9933         DO 5 I=0,4
9934           DO 6 K=0,4
9935             J = J+1
9936             SIGTAB(IP,J,IE) = SIGVM(I,K)
9937  6        CONTINUE
9938  5      CONTINUE
9939         SIGTAB(IP,28,IE) = SIGINE
9940         SIGTAB(IP,29,IE) = SIGDIR
9941         SIGTAB(IP,30,IE) = SIGLSD(1)
9942         SIGTAB(IP,31,IE) = SIGLSD(2)
9943         SIGTAB(IP,32,IE) = SIGHSD(1)
9944         SIGTAB(IP,33,IE) = SIGHSD(2)
9945         SIGTAB(IP,34,IE) = SIGLDD
9946         SIGTAB(IP,35,IE) = SIGHDD
9947         SIGTAB(IP,36,IE) = SIGCDF(0)
9948         SIGTAB(IP,37,IE) = SIG1SO
9949         SIGTAB(IP,38,IE) = SIG1HA
9950         SIGTAB(IP,39,IE) = SLOEL
9951         J = 39
9952         DO 7 I=1,4
9953           DO 8 K=1,4
9954             J = J+1
9955             SIGTAB(IP,J,IE) = SLOVM(I,K)
9956  8        CONTINUE
9957  7      CONTINUE
9958         SIGTAB(IP,56,IE) = SIGPOM
9959         SIGTAB(IP,57,IE) = SIGREG
9960         SIGTAB(IP,58,IE) = SIGHAR
9961         SIGTAB(IP,59,IE) = SIGDIR
9962         SIGTAB(IP,60,IE) = SIGTR1(1)
9963         SIGTAB(IP,61,IE) = SIGTR1(2)
9964         SIGTAB(IP,62,IE) = SIGTR2(1)
9965         SIGTAB(IP,63,IE) = SIGTR2(2)
9966         SIGTAB(IP,64,IE) = SIGLOO
9967         SIGTAB(IP,65,IE) = SIGDPO(1)
9968         SIGTAB(IP,66,IE) = SIGDPO(2)
9969         SIGTAB(IP,67,IE) = SIGDPO(3)
9970         SIGTAB(IP,68,IE) = SIGDPO(4)
9971
9972 C  consistency check
9973         SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9974      &          -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9975      &          -SIGLDD-SIGHDD
9976
9977         IF(SIGNDF.LE.0.D0) THEN
9978           WRITE(LO,'(//1X,A,/)')
9979      &      'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
9980           WRITE(LO,'(1X,A,I3,1P,2E12.4)')
9981      &      'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
9982           WRITE(LO,'(4X,A,/1P,8E10.3)')
9983      &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
9984      &      SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
9985      &      SIGLSD(2),SIGLDD
9986           STOP
9987         ENDIF
9988
9989         IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
9990           print LO,'------------------------------------------------'
9991           print LO,'IP,ECM:',IP,ECM
9992           print LO,'SIGTOT:',SIGTOT
9993           print LO,'SIGELA:',SIGELA
9994           print LO,'SIGVM :',SIGVM(0,0)
9995           print LO,'SIGCDF:',SIGCDF(0)
9996           print LO,'SIGDIR:',SIGDIR
9997           print LO,'SIGLSD:',SIGLSD
9998           print LO,'SIGHSD:',SIGHSD
9999           print LO,'SIGLDD:',SIGLDD
10000           print LO,'SIGHDD:',SIGHDD
10001           print LO,'SIGNDF:',SIGNDF
10002
10003           print LO,'SIGPOM:',SIGPOM
10004           print LO,'SIGREG:',SIGREG
10005           print LO,'SIGHAR:',SIGHAR
10006           print LO,'SIGDIR:',SIGDIR
10007           print LO,'SIGTR1:',SIGTR1
10008           print LO,'SIGTR2:',SIGTR2
10009           print LO,'SIGLOO:',SIGLOO
10010           print LO,'SIGDPO:',SIGDPO
10011           print LO,'SIG1SO:',SIG1SO
10012           print LO,'SIG1HA:',SIG1HA
10013         ENDIF
10014
10015         SIGTAB(IP,77,IE) = PTCUT(IP)
10016         SIGTAB(IP,78,IE) = SIGNDF
10017
10018         AUXFAC = PI2/SIGNDF
10019         IF(ISWMDL(1).EQ.3) THEN
10020           DO 133 I=1,4
10021             AMPCOF(I) = 0.D0
10022             DO 135 K=1,4
10023               AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
10024  135        CONTINUE
10025             AMPCOF(I) = AMPCOF(I)*AUXFAC
10026  133      CONTINUE
10027         ENDIF
10028 C
10029 *       BMAX=5.D0*SQRT(DBLE(BPOM))
10030         BMAX=10.D0
10031         EPTAB(IP,IE) = ECM
10032         CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
10033 C
10034       ENDIF
10035 C
10036       DO 160 K=0,KMAX
10037         DO 170 I=0,IMAX
10038           PROB(IP,IE,I,K) = 0.D0
10039  170    CONTINUE
10040  160  CONTINUE
10041       DO 120 I=1,ICHMAX
10042         PCHAIN(1,I) = 0.D0
10043         PCHAIN(2,I) = 0.D0
10044  120  CONTINUE
10045 C
10046 C  main cross section loop
10047 C**********************************************************
10048       DO 5000 IB=1,NGAUSO
10049         B24=XPNT(IB)**2/4.D0
10050         FAC = XPNT(IB)*WGHT(IB)
10051 C
10052         IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
10053 C
10054 C  amplitude construction
10055           DO 525 I=1,4
10056             AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
10057      &              +ZXR(1,I)*EXP(-B24/BXR(1,I))
10058             AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
10059             AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
10060      &              -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
10061      &              -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
10062      &              -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
10063      &              -ZXL(1,I)*EXP(-B24/BXL(1,I))
10064             AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
10065      &              +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
10066      &              +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
10067      &              +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
10068             AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
10069             AB(2,I) = AB(2,I)
10070             AB(3,I) = 0.D0
10071             AB(4,I) = 0.D0
10072 *
10073  525      CONTINUE
10074 C
10075           DO 460 I=1,4
10076             DO 500 K=1,4
10077               ABSUM2(I,K) = 0.D0
10078               DO 550 L=1,4
10079                 ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
10080  550          CONTINUE
10081               ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
10082  500        CONTINUE
10083  460      CONTINUE
10084           DO 600 I=1,4
10085             CHI2(I) = 0.D0
10086             DO 650 K=1,4
10087               CHI2(I) = CHI2(I) + ABSUM2(K,I)
10088  650        CONTINUE
10089  600      CONTINUE
10090 C  sums instead of products
10091           DO 660 I=1,4
10092             DO 670 KD=1,4
10093               DTMP = ABS(ABSUM2(I,KD))
10094               IF(DTMP.LT.1.D-30) THEN
10095                 ABSUM2(I,KD) = -50.D0
10096               ELSE
10097                 ABSUM2(I,KD) = LOG(DTMP)
10098               ENDIF
10099  670        CONTINUE
10100  660      CONTINUE
10101
10102           IF(MAX(IMAX,KMAX).GT.30) THEN
10103             WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
10104      &        'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
10105             CALL PHO_ABORT
10106           ENDIF
10107
10108           DO 700 KD=1,4
10109             DO 750 I=1,4
10110               ABSTMP(I) = ABSUM2(I,KD)
10111  750        CONTINUE
10112 C  recursive sum
10113             CHITMP(1) = -ABSUM2(1,KD)
10114             DO 800 I=0,IMAX
10115               CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
10116               CHITMP(2) = -ABSTMP(2)
10117               DO 810 K=0,KMAX
10118                 CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
10119 C  calculation of elastic part
10120                 DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
10121                 IF(DTMP.LT.-30.D0) THEN
10122                   DTMP = 0.D0
10123                 ELSE
10124                   DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
10125                 ENDIF
10126                 PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
10127  810          CONTINUE
10128  800        CONTINUE
10129  700      CONTINUE
10130           PROB(IP,IE,0,0) = 0.D0
10131 C
10132 C**********************************************************
10133         ELSE
10134           WRITE(LO,'(1X,A,I3)')
10135      &      'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
10136           STOP
10137         ENDIF
10138  5000 CONTINUE
10139
10140 C  debug output
10141       IF(IDEB(55).GE.15) THEN
10142         WRITE(LO,'(/,1X,A,I3,E11.4)')
10143      &    'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
10144      &    IP,ECM
10145         DO 905 I=0,MIN(IMAX,5)
10146           DO 915 K=0,MIN(KMAX,5)
10147             IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
10148      &        WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
10149  915      CONTINUE
10150  905    CONTINUE
10151       ENDIF
10152 C  string probability (uncorrected)
10153       IF(IDEB(55).GE.5) THEN
10154         DO 955 I=0,IMAX
10155           DO 965 K=0,KMAX
10156             INDX = 2*I+2*K
10157             IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
10158               PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
10159             ENDIF
10160  965      CONTINUE
10161  955    CONTINUE
10162         WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
10163      &    'list of selected probabilities (uncorr,ECM)',ECM
10164         WRITE(LO,'(10X,A)') 'I,   0HPOM,   1HPOM,   2HPOM'
10165         DO 183 I=0,IIMAX
10166           IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
10167      &      WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
10168      &      PROB(IP,IE,I,1),PROB(IP,IE,I,2)
10169  183    CONTINUE
10170       ENDIF
10171 C  substract high-mass single and double diffraction
10172       PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
10173      &                 -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
10174       PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
10175 C
10176 C  probability check
10177       CHKSUM = 0.D0
10178       PRONEG = 0.D0
10179       AVERI =  0.D0
10180       AVERK =  0.D0
10181       AVERL =  0.D0
10182       AVERM =  0.D0
10183       AVERN =  0.D0
10184       SIGMI =  0.D0
10185       SIGMK =  0.D0
10186       SIGML =  0.D0
10187       SIGMM =  0.D0
10188       DO 1001 I=0,IMAX
10189         PSOFT(I) = 0.D0
10190  1001 CONTINUE
10191       DO 1002 K=0,KMAX
10192         PHARD(K) = 0.D0
10193  1002 CONTINUE
10194       DO 1000 K=0,KMAX
10195         DO 1010 I=0,IMAX
10196           TMP = PROB(IP,IE,I,K)
10197           IF(TMP.LT.0.D0) THEN
10198             IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
10199               WRITE(LO,'(1X,A,4I4,E14.4)')
10200      &          'PHO_PRBDIS: neg.probability:',
10201      &              IP,IE,I,K,PROB(IP,IE,I,K)
10202             ENDIF
10203             PRONEG = PRONEG+TMP
10204             TMP = 0.D0
10205           ENDIF
10206           CHKSUM = CHKSUM+TMP
10207           AVERI = AVERI+DBLE(I)*TMP
10208           AVERK = AVERK+DBLE(K)*TMP
10209           SIGMI = SIGMI+DBLE(I**2)*TMP
10210           SIGMK = SIGMK+DBLE(K**2)*TMP
10211           PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
10212           PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
10213           PROB(IP,IE,I,K) = CHKSUM
10214  1010   CONTINUE
10215  1000 CONTINUE
10216 C
10217       IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
10218      &  'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
10219 C  cut probabilites output
10220       IF(IDEB(55).GE.5) THEN
10221         WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
10222         DO 185 I=1,ICHMAX
10223           IF(ABS(PCHAIN(1,I)).GT.1.D-10)
10224      &      WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
10225  185    CONTINUE
10226       ENDIF
10227 C  rescaling necessary
10228       IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
10229         FAC = 1.D0/CHKSUM
10230         IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
10231      &    'PHO_PRBDIS: rescaling of probabilities with factor',FAC
10232         DO 40 K=0,KMAX
10233           DO 50 I=0,IMAX
10234             PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
10235   50      CONTINUE
10236   40    CONTINUE
10237         AVERI = AVERI*FAC
10238         AVERK = AVERK*FAC
10239         AVERL = AVERL*FAC
10240         AVERM = AVERM*FAC
10241         SIGMI = SIGMI*FAC**2
10242         SIGMK = SIGMK*FAC**2
10243         SIGML = SIGML*FAC**2
10244         SIGMM = SIGMM*FAC**2
10245       ENDIF
10246 C
10247 C  probability to find Reggeon/Pomeron
10248       PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
10249       AVERJ = -PROB(IP,IE,0,0)*AVERI
10250       AVERII = AVERI-AVERJ
10251 C
10252       SIGTAB(IP,74,IE) = AVERII
10253       SIGTAB(IP,75,IE) = AVERK
10254       SIGTAB(IP,76,IE) = AVERJ
10255 C
10256       SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
10257       SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
10258 C
10259       IF(IDEB(55).GE.1) THEN
10260
10261 C  average interaction probabilities
10262         WRITE(LO,'(/1X,A,/1X,A)')
10263      &    'PHO_PRBDIS: expected interaction statistics',
10264      &    '-------------------------------------------'
10265         WRITE(LO,'(1X,A,E12.4,2I3)')
10266      &    'energy,IP,table index:',EPTAB(IP,IE),IP,IE
10267         WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
10268      &    IMAX,KMAX
10269         WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
10270      &    'averaged number of cuts per event (eff. cs):',SIGNDF,
10271      &    ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
10272      &    AVERII,AVERK,AVERJ,AVERL,AVERM,
10273      &    AVERI+AVERK+AVERL+AVERM
10274         WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
10275      &    'standard deviation ( sqrt(sigma) ):',
10276      &    ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
10277      &    SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
10278      &    SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
10279         WRITE(LO,'(1X,A)') 'cross section / probability  soft, hard'
10280         DO I=0,MIN(IMAX,KMAX)
10281           WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
10282      &      I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
10283         ENDDO
10284
10285 C  cross check of probability distribution and inclusive cross section
10286         PSsum_1 = 0.D0
10287         PSsum_2 = 0.D0
10288         PHsum_1 = 0.D0
10289         PHsum_2 = 0.D0
10290         do i=1,IMAX
10291           PSsum_1 = PSsum_1+PSOFT(i)*FAC
10292           PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
10293         enddo
10294         do k=1,KMAX
10295           PHsum_1 = PHsum_1+PHARD(k)
10296           PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
10297         enddo
10298         WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
10299      &    PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
10300
10301       ENDIF
10302
10303       END
10304
10305 CDECK  ID>, PHO_SAMPRO
10306       SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
10307 C***********************************************************************
10308 C
10309 C     routine to sample kind of process
10310 C
10311 C     input:   IP        particle combination
10312 C              IFP1/2    PDG number of particle 1/2
10313 C              ECM       c.m. energy (GeV)
10314 C              PVIR1/2   virtuality of particle 1/2 (GeV**2, positive)
10315 C              SPROB     suppression factor for processes 1-7
10316 C                        due to rapidity gap survival probability
10317 C              IPROC     mode
10318 C                          -2     output of statistics
10319 C                          -1     initialization
10320 C                           0     sampling of process
10321 C
10322 C     output:  IPROC     kind of interaction process:
10323 C                           1  non-diffractive resolved process
10324 C                           2  elastic scattering
10325 C                           3  quasi-elastic rho/omega/phi production
10326 C                           4  central diffraction
10327 C                           5  single diffraction according to IDIFF1
10328 C                           6  single diffraction according to IDIFF2
10329 C                           7  double diffraction
10330 C                           8  single-resolved / direct processes
10331 C
10332 C***********************************************************************
10333
10334       IMPLICIT NONE
10335
10336       SAVE
10337
10338       INTEGER IP,IFP1,IFP2,IPROC
10339       DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
10340
10341 C  input/output channels
10342       INTEGER LI,LO
10343       COMMON /POINOU/ LI,LO
10344 C  event debugging information
10345       INTEGER NMAXD
10346       PARAMETER (NMAXD=100)
10347       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10348      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10349       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10350      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10351 C  cross sections
10352       INTEGER IPFIL,IFAFIL,IFBFIL
10353       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10354      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10355      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10356      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10357      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10358       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10359      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10360      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10361      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10362      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10363      &                IPFIL,IFAFIL,IFBFIL
10364 C  model switches and parameters
10365       CHARACTER*8 MDLNA
10366       INTEGER ISWMDL,IPAMDL
10367       DOUBLE PRECISION PARMDL
10368       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10369 C  general process information
10370       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10371       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10372 C  event weights and generated cross section
10373       INTEGER IPOWGC,ISWCUT,IVWGHT
10374       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
10375       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
10376      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
10377
10378       DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
10379       DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
10380       DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
10381
10382       INTEGER I,K,KMAX
10383       DOUBLE PRECISION DT_RNDM
10384       DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
10385
10386       IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
10387      &  'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
10388      &  IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10389
10390       IF(IPROC.GE.0) THEN
10391
10392 C  interpolate cross sections
10393         CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
10394
10395 C  cross check
10396         IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
10397           WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
10398      &      'PHO_SAMPRO: inconsistent gap survival probability',
10399      &      'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
10400      &      KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10401         ENDIF
10402
10403 C  calculate cumulative probabilities
10404         IF(ISWMDL(1).EQ.3) THEN
10405           IF(ISWMDL(2).GE.1) THEN
10406             SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
10407             SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
10408             SIGDDI    = SIGLDD+SIGHDD
10409             SIGNDR    = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10410      &                - SIGSDI(1)-SIGSDI(2)-SIGDDI
10411             XPROB(1)  = SIGNDR*SPROB*DBLE(IPRON(1,IP))
10412             XPROB(2)  = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
10413             XPROB(3)  = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
10414             XPROB(4)  = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
10415             XPROB(5)  = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
10416             XPROB(6)  = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
10417             XPROB(7)  = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
10418             XPROB(8)  = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
10419           ELSE
10420             SIGHR = 0.D0
10421             IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
10422             SIGHD = 0.D0
10423             IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
10424             XPROB(1) = SIGHR/(SIGHR+SIGHD)
10425             XPROB(2) = XPROB(1)
10426             XPROB(3) = XPROB(1)
10427             XPROB(4) = XPROB(1)
10428             XPROB(5) = XPROB(1)
10429             XPROB(6) = XPROB(1)
10430             XPROB(7) = XPROB(1)
10431             XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
10432           ENDIF
10433
10434           IF(IDEB(11).GE.15) THEN
10435             WRITE(LO,'(1X,A,I3)')
10436      &        'PHO_SAMPRO: partial cross sections for IP',IP
10437             WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
10438             DO 240 I=2,8
10439               WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
10440  240        CONTINUE
10441           ENDIF
10442
10443         ELSE
10444           WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
10445      &      ISWMDL(1)
10446           CALL PHO_ABORT
10447         ENDIF
10448
10449         IF(XPROB(8).LT.1.D-20) THEN
10450           IF(IDEB(11).GE.2)
10451      &      WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
10452      &      'activated processes have vanishing cross section sum',
10453      &      'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
10454           IPROC = 0
10455           RETURN
10456         ENDIF
10457
10458 C  sample process
10459         XI = DT_RNDM(XI)*XPROB(8)
10460         DO 100 I=1,8
10461           IF(XI.LE.XPROB(I)) GOTO 110
10462  100    CONTINUE
10463  110    CONTINUE
10464         IPROC = MIN(I,8)
10465
10466         CALLS(IP)     = CALLS(IP)+1.D0
10467         PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
10468         ECMSUM(IP)    = ECMSUM(IP)+ECM
10469         IF(ISWMDL(2).GE.1) THEN
10470           SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
10471         ELSE
10472           SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
10473         ENDIF
10474
10475 C  debug output
10476         IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
10477      &    'PHO_SAMPRO: IP,CALL,PROC-ID',
10478      &    IP,INT(CALLS(IP)+0.1D0),IPROC
10479
10480 C  statistics initialization
10481       ELSE IF(IPROC.EQ.-1) THEN
10482         DO 260 K=1,4
10483           DO 250 I=1,8
10484             PRO(I,K) = 0.D0
10485  250      CONTINUE
10486           CALLS(K)  = 0.D0
10487           SIGSUM(K) = 0.D0
10488           ECMSUM(K) = 0.D0
10489  260    CONTINUE
10490
10491 C  write out statistics
10492       ELSE IF(IPROC.EQ.-2) THEN
10493         KMAX = 4
10494         IF(ISWMDL(2).EQ.0) KMAX=1
10495         DO 270 K=1,KMAX
10496           IF(CALLS(K).GT.0.5D0) THEN
10497             SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
10498             ECMSUM(K) = ECMSUM(K)/CALLS(K)
10499             IF(IDEB(11).GE.0) THEN
10500 C *** Commented by Chiara
10501 C              WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
10502 C     &          'PHO_SAMPRO: internal process statistics ',
10503 C     &          '(IP,<Ecm>)',K,ECMSUM(K),
10504 C     &          '---------------------------------------'
10505 C              WRITE(LO,'(8X,A)')
10506 C     &          '        process      sampled    cross section'
10507 C              IF(ISWMDL(2).GE.1) THEN
10508 C                WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
10509 C     &            '    all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10510 C     &            ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
10511 C     &            '          elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
10512 C     &            'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
10513 C     &            '   double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
10514 C     &            ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
10515 C     &            ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
10516 C     &            ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
10517 C     &            ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
10518 C              ELSE
10519 C                WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
10520 C     &            '    all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10521 C     &            '  double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
10522 C     &            ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
10523 C              ENDIF
10524             ENDIF
10525           ENDIF
10526  270    CONTINUE
10527       ENDIF
10528
10529       END
10530
10531 CDECK  ID>, PHO_SAMPRB
10532       SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
10533 C********************************************************************
10534 C
10535 C     routine to sample number of cut graphs of different kind
10536 C
10537 C     input:  IP      scattering particle combination
10538 C             ECMI    CMS energy
10539 C             IP      -1         initialization
10540 C                     -2         output of statistics
10541 C                     others     sampling of cuts
10542 C
10543 C     output: ISAM    number of soft Pomerons cut
10544 C             JSAM    number of soft Reggeons cut
10545 C             KSAM    number of hard Pomerons cut
10546 C
10547 C     PHO_PRBDIS has to be called before
10548 C
10549 C********************************************************************
10550       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10551       SAVE
10552
10553 C  input/output channels
10554       INTEGER LI,LO
10555       COMMON /POINOU/ LI,LO
10556 C  event debugging information
10557       INTEGER NMAXD
10558       PARAMETER (NMAXD=100)
10559       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10560      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10561       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10562      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10563 C  model switches and parameters
10564       CHARACTER*8 MDLNA
10565       INTEGER ISWMDL,IPAMDL
10566       DOUBLE PRECISION PARMDL
10567       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10568 C  general process information
10569       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10570       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10571 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
10572       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
10573       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
10574       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
10575      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
10576 C  obsolete cut-off information
10577       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10578       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10579 C  cut probability distribution
10580       INTEGER IEETA1,IIMAX,KKMAX
10581       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
10582       INTEGER IEEMAX,IMAX,KMAX
10583       REAL PROB
10584       DOUBLE PRECISION EPTAB
10585       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
10586      &                IEEMAX,IMAX,KMAX
10587 C  global event kinematics and particle IDs
10588       INTEGER IFPAP,IFPAB
10589       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
10590       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
10591 C  cross sections
10592       INTEGER IPFIL,IFAFIL,IFBFIL
10593       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10594      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10595      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10596      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10597      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10598       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10599      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10600      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10601      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10602      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10603      &                IPFIL,IFAFIL,IFBFIL
10604 C  table of particle indices for recursive PHOJET calls
10605       INTEGER MAXIPX
10606       PARAMETER ( MAXIPX = 100 )
10607       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
10608       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
10609      &                IPOIX1,IPOIX2,IPOIX3
10610
10611       DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
10612
10613 C  sample number of interactions
10614       IF(IP.GE.0) THEN
10615         ITER = 0
10616         ECMX = ECMI
10617         ECMC = ECMI
10618         KLIM = 1
10619         IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
10620           IF(IPAMDL(16).EQ.0) ECMC = SECM
10621           KLIM = 0
10622         ENDIF
10623
10624 C  sample up to kinematic limits only
10625         IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
10626         IF(IMAX1.LT.1) THEN
10627           IF(IPAMDL(2).EQ.1) THEN
10628 C  reggeon allowed
10629             ISAM = 0
10630             JSAM = 1
10631             KSAM = 0
10632             AVERB(3,IP) = AVERB(3,IP)+1.D0
10633           ELSE
10634 C  only pomeron even at very low energies
10635             ISAM = 1
10636             JSAM = 0
10637             KSAM = 0
10638             AVERB(1,IP) = AVERB(1,IP)+1.D0
10639           ENDIF
10640           AVERB(0,IP) = AVERB(0,IP)+1.D0
10641           GOTO 150
10642         ENDIF
10643 C  find interpolation factors
10644         IF(ECMX.LE.EPTAB(IP,1)) THEN
10645           I1 = 1
10646           I2 = 1
10647         ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
10648           DO 50 I=2,IEEMAX
10649             IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
10650  50       CONTINUE
10651  200      CONTINUE
10652           I1 = I-1
10653           I2 = I
10654         ELSE
10655           WRITE(LO,'(/1X,A,2E12.3)')
10656      &      'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
10657           CALL PHO_PREVNT(-1)
10658           I1 = IEEMAX
10659           I2 = IEEMAX
10660         ENDIF
10661         FAC2 = 0.D0
10662         IF(I1.NE.I2)
10663      &    FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
10664         FAC1=1.D0-FAC2
10665 C  reggeon probability
10666         PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
10667 C  calculate soft suppression factor
10668         IF(IP.EQ.1) FSUPP = PARMDL(35)**2
10669      &         /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
10670 C
10671  10     CONTINUE
10672         ITER = ITER+1
10673         XI = DT_RNDM(FAC2)
10674         DO 260 KSAM=0,KMAX
10675           DO 270 ISAM=0,IMAX
10676             PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
10677      &           +PROB(IP,I2,ISAM,KSAM)*FAC2
10678             IF(PRO.GT.XI) GOTO 100
10679  270      CONTINUE
10680  260    CONTINUE
10681         ISAM = MIN(IMAX,ISAM)
10682         KSAM = MIN(KMAX,KSAM)
10683
10684  100    CONTINUE
10685
10686         IF(ITER.GT.100) THEN
10687
10688           ISAM = 0
10689           JSAM = 1
10690           KSAM = 0
10691           IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
10692      &      'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
10693
10694         ELSE
10695
10696 C  reggeon contribution
10697           JSAM = 0
10698           IF(IPAMDL(2).EQ.1) THEN
10699             DO 90 I=1,ISAM
10700               IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
10701  90         CONTINUE
10702             ISAM = ISAM-JSAM
10703           ENDIF
10704 C  statistics of bare cuts
10705           IF(ITER.EQ.1) THEN
10706             AVERB(0,IP) = AVERB(0,IP)+1.D0
10707             AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
10708             AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
10709             AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
10710           ENDIF
10711 C  limitation given by field dimensions
10712           IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
10713
10714           IF(IP.EQ.1) THEN
10715
10716 C  reweight according to virtualities and PDF treatment
10717             IF(IPAMDL(115).GE.1) THEN
10718               IF(KSAM.EQ.0) THEN
10719                 IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
10720               ENDIF
10721             ENDIF
10722
10723 C  reduce number of cuts according to photon virtualities
10724             IF(IPAMDL(114).GE.1) THEN
10725  110          CONTINUE
10726               I = ISAM+JSAM
10727               WGX = FSUPP**I
10728               IF(DT_RNDM(WGX).GT.WGX) THEN
10729                 IF(ISAM+JSAM+KSAM.GT.1) THEN
10730                   IF(JSAM.GT.0) THEN
10731                     JSAM = JSAM-1
10732                     GOTO 110
10733                   ELSE IF(ISAM.GT.0) THEN
10734                     ISAM = ISAM-1
10735                     GOTO 110
10736                   ENDIF
10737                 ENDIF
10738               ENDIF
10739             ENDIF
10740
10741           ENDIF
10742
10743 C  phase space limitation
10744  120      CONTINUE
10745           XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
10746      &        +DBLE(2*KSAM)*PTCUT(IP)
10747           PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
10748           IF(DT_RNDM(XM).GT.PACC) THEN
10749             IF(ISAM+JSAM+KSAM.GT.1) THEN
10750               IF(JSAM.GT.0) THEN
10751                 JSAM = JSAM-1
10752                 GOTO 120
10753               ELSE IF(ISAM.GT.0) THEN
10754                 ISAM = ISAM-1
10755                 GOTO 120
10756               ELSE IF(KSAM.GT.KLIM) THEN
10757                 KSAM = KSAM-1
10758                 GOTO 120
10759               ENDIF
10760             ENDIF
10761           ENDIF
10762
10763         ENDIF
10764
10765         ISAM = ISAM+JSAM/2
10766         JSAM = MOD(JSAM,2)
10767 C  collect statistics
10768  150    CONTINUE
10769         ECMS1(IP) = ECMS1(IP)+ECMX
10770         ECMS2(IP) = ECMS2(IP)+ECMC
10771
10772         AVERC(0,IP) = AVERC(0,IP)+1.D0
10773         AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
10774         AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
10775         AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
10776 C
10777         IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
10778      &    'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
10779 C
10780 C  initialize statistics
10781       ELSE IF(IP.EQ.-1) THEN
10782         DO 60 I=1,4
10783           ECMS1(I) = 0.D0
10784           ECMS2(I) = 0.D0
10785           DO 65 K=0,3
10786             AVERB(K,I) = 0.D0
10787             AVERC(K,I) = 0.D0
10788  65       CONTINUE
10789
10790  60     CONTINUE
10791         RETURN
10792 C
10793 C  write out statistics
10794       ELSE IF(IP.EQ.-2) THEN
10795 C *** Commented by Chiara
10796 C        WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
10797 C     &                        '----------------------------------'
10798         DO 70 I=1,4
10799           IF(AVERB(0,I).LT.2.D0) GOTO 75
10800 C          WRITE(LO,'(1X,A,I3,1P,2E13.3)')
10801 C     &      'statistics for IP,<Ecm_1>,<Ecm_2>',I,
10802 C     &      ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
10803 C          WRITE(LO,'(5X,A)')
10804 C     &      'average number of s-pom,h-pom,reg cuts (bare)'
10805 C          WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
10806 C     &      (AVERB(K,I)/AVERB(0,I),K=1,3)
10807 C          WRITE(LO,'(5X,A)')
10808 C     &      'average (with energy/virtuality corrections)'
10809 C          WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
10810 C     &      (AVERC(K,I)/AVERC(0,I),K=1,3)
10811
10812  75       CONTINUE
10813  70     CONTINUE
10814         RETURN
10815       ENDIF
10816       END
10817
10818 CDECK  ID>, PHO_TRIREG
10819       SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
10820      &                     SIGTR,BTR)
10821 C**********************************************************************
10822 C
10823 C     calculation of triple-Pomeron total cross section
10824 C     according to Gribov's Regge theory
10825 C
10826 C     input:        S        squared cms energy
10827 C                   GA       coupling constant to diffractive line
10828 C                   AA       slope related to GA (GeV**-2)
10829 C                   GB       coupling constant to elastic line
10830 C                   BB       slope related to GB (GeV**-2)
10831 C                   DELTA    effective pomeron delta (intercept-1)
10832 C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
10833 C                   GPPP     triple-Pomeron coupling
10834 C                   BPPP     slope related to B0PPP (GeV**-2)
10835 C                   VIR2A    virtuality of particle a (GeV**2)
10836 C                   note: units of all coupling constants are mb**1/2
10837 C
10838 C     output:       SIGTR    total triple-Pomeron cross section
10839 C                   BTR      effective triple-Pomeron slope
10840 C                            (differs from diffractive slope!)
10841 C
10842 C     uses E_i (Exponential-Integral function)
10843 C
10844 C**********************************************************************
10845       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10846       SAVE
10847
10848       PARAMETER (EPS =0.0001D0)
10849
10850 C  input/output channels
10851       INTEGER LI,LO
10852       COMMON /POINOU/ LI,LO
10853 C  event debugging information
10854       INTEGER NMAXD
10855       PARAMETER (NMAXD=100)
10856       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10857      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10858       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10859      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10860 C  some constants
10861       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10862       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10863      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10864
10865 C  integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10866       SIGU = 2.5
10867 C  integration cut-off Sigma_L (min. squared mass of diff. blob)
10868       SIGL = 5.+VIR2A
10869 C  debug output
10870       IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10871      &       'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10872      &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10873 C
10874       IF(S.LT.5.D0) THEN
10875         SIGTR = 0.D0
10876         BTR = BPPP+BB
10877         RETURN
10878       ENDIF
10879 C  change units of ALPHAP to mb
10880       ALSCA  = ALPHAP*GEV2MB
10881 C
10882 C  cross section
10883       PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
10884      &        EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
10885       PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
10886       PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
10887 C
10888       SIGTR=PART1*(PART2-PART3)
10889 C
10890 C  slope
10891       PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
10892      &        (BB+BPPP+2.*ALPHAP*LOG(SIGU))
10893       PART2 = LOG(PART1)
10894       PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
10895       BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
10896       BTR = BTR-PART1
10897 C
10898       IF(SIGTR.LT.EPS) SIGTR = 0.D0
10899       IF(BTR.LT.BB)  BTR = BB
10900 C
10901       IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10902      &  'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
10903       END
10904
10905 CDECK  ID>, PHO_LOOREG
10906       SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
10907      &                     VIR2A,VIR2B,SIGLO,BLO)
10908 C**********************************************************************
10909 C
10910 C     calculation of loop-Pomeron total cross section
10911 C     according to Gribov's Regge theory
10912 C
10913 C     input:        S        squared cms energy
10914 C                   GA       coupling constant to diffractive line
10915 C                   AA       slope related to GA (GeV**-2)
10916 C                   GB       coupling constant to elastic line
10917 C                   BB       slope related to GB (GeV**-2)
10918 C                   DELTA    effective pomeron delta (intercept-1)
10919 C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
10920 C                   GPPP     triple-Pomeron coupling
10921 C                   BPPP     slope related to B0PPP (GeV**-2)
10922 C                   VIR2A    virtuality of particle a (GeV**2)
10923 C                   VIR2B    virtuality of particle b (GeV**2)
10924 C                   note: units of all coupling constants are mb**1/2
10925 C
10926 C     output:       SIGLO    total loop-Pomeron cross section
10927 C                   BLO      effective loop-Pomeron slope
10928 C                            (differs from double diffractive slope!)
10929 C
10930 C     uses E_i (Exponential-Integral function)
10931 C
10932 C**********************************************************************
10933       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10934       SAVE
10935
10936       PARAMETER (EPS =0.0001D0)
10937
10938 C  input/output channels
10939       INTEGER LI,LO
10940       COMMON /POINOU/ LI,LO
10941 C  event debugging information
10942       INTEGER NMAXD
10943       PARAMETER (NMAXD=100)
10944       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10945      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10946       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10947      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10948 C  some constants
10949       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10950       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10951      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10952
10953 C  integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10954       SIGU = 2.5
10955 C  integration cut-off Sigma_L (min. squared mass of diff. blob)
10956       SIGL = 5.+VIR2A+VIR2B
10957 C  debug output
10958       IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10959      &       'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10960      &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10961 C
10962       IF(S.LT.5.D0) THEN
10963         SIGLO = 0.D0
10964         BLO = 2.D0*BPPP
10965         RETURN
10966       ENDIF
10967
10968 C
10969 C  change units of ALPHAP to mb
10970       ALSCA  = ALPHAP*GEV2MB
10971 C
10972 C  cross section
10973       PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
10974      &        EXP(-DELTA*BPPP/ALPHAP)
10975       PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
10976       PARTB=BPPP/ALPHAP+LOG(SIGU)
10977       SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
10978      &                    -PHO_EXPINT(PARTB*DELTA))
10979      &             +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
10980      &            )
10981 C
10982 C  slope
10983       PART1 = LOG(ABS(PARTA/PARTB))
10984      &       *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
10985       PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
10986       BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
10987       BLO = BLO-PART1
10988 C
10989       IF(SIGLO.LT.EPS) SIGLO = 0.D0
10990       IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
10991 C
10992       IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10993      &  'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
10994       END
10995
10996 CDECK  ID>, PHO_TRXPOM
10997       SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
10998      &                     GPPP,BPPP,SIGDP,BDP)
10999 C**********************************************************************
11000 C
11001 C     calculation of total cross section of two tripe-Pomeron
11002 C     graphs in X configuration according to Gribov's Reggeon field
11003 C     theory
11004 C
11005 C     input:        S        squared cms energy
11006 C                   GA       coupling constant to elastic line 1
11007 C                   AA       slope related to GA (GeV**-2)
11008 C                   GB       coupling constant to elastic line 2
11009 C                   BB       slope related to GB (GeV**-2)
11010 C                   DELTA    effective pomeron delta (intercept-1)
11011 C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
11012 C                   BPPP     triple-Pomeron coupling
11013 C                   BTR      slope related to B0PPP (GeV**-2)
11014 C                   note: units of all coupling constants are mb**1/2
11015 C
11016 C     output:       SIGDP    total cross section for double-Pomeron
11017 C                            scattering
11018 C                   BDP      effective double-Pomeron slope
11019 C
11020 C**********************************************************************
11021       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11022       SAVE
11023
11024       PARAMETER (EPS =0.0001D0)
11025
11026 C  input/output channels
11027       INTEGER LI,LO
11028       COMMON /POINOU/ LI,LO
11029 C  event debugging information
11030       INTEGER NMAXD
11031       PARAMETER (NMAXD=100)
11032       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11033      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11034       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11035      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11036 C  model switches and parameters
11037       CHARACTER*8 MDLNA
11038       INTEGER ISWMDL,IPAMDL
11039       DOUBLE PRECISION PARMDL
11040       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11041 C  some constants
11042       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11043       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11044      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11045
11046       DIMENSION XWGH1(96),XPOS1(96)
11047
11048 C  lower integration cut-off Sigma_L
11049       SIGL = PARMDL(71)**2
11050 C  upper integration cut-off Sigma_U
11051       C = 1.D0-1.D0/PARMDL(70)**2
11052       C = MAX(PARMDL(72),C)
11053       SIGU = (1.D0-C)**2*S
11054 C  integration precision
11055       NGAUS1=16
11056 C
11057 C  debug output
11058       IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11059      &       'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
11060      &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11061 C
11062       IF(SIGU.LE.SIGL) THEN
11063         SIGDP = 0.D0
11064         BDP = AA+BB
11065         RETURN
11066       ENDIF
11067 C
11068 C  cross section
11069 C
11070       XIL = LOG(SIGL)
11071       XIU = LOG(SIGU)
11072       XI = LOG(S)
11073       FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
11074       ALPHA2 = 2.D0*ALPHAP
11075       ALOC = LOG(1.D0/(1.D0-C))
11076       CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
11077       XSUM = 0.D0
11078       DO 100 I1=1,NGAUS1
11079         AMXSQ  = EXP(XPOS1(I1))
11080         ALOSMX = LOG(S/AMXSQ)
11081         ALCSMX = LOG((1.D0-C)*S/AMXSQ)
11082         W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
11083         W = MAX(0.D0,W)
11084         WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
11085 C  supercritical part
11086         WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
11087         XSUM = XSUM + W*XWGH1(I1)/WN*WSC
11088  100  CONTINUE
11089       SIGDP = XSUM*FAC
11090 C
11091 C  slope
11092       BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
11093 C
11094       IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11095      &  'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
11096       END
11097
11098 CDECK  ID>, PHO_CHAN2A
11099       SUBROUTINE PHO_CHAN2A(BB)
11100 C***********************************************************************
11101 C
11102 C     simple two channel model to realize low mass diffraction
11103 C     (version A, iteration of triple- and loop-Pomeron)
11104 C
11105 C     input:     BB      impact parameter (mb**1/2)
11106 C
11107 C     output:    /POINT4/
11108 C                AMPEL      elastic amplitude
11109 C                AMPVM(4,4) q-elastic VM production
11110 C                AMLMSD(2)  low mass single diffraction amplitude
11111 C                AMHMSD(2)  high mass single diffraction amplitude
11112 C                AMLMDD     low mass double diffraction amplitude
11113 C                AMHMDD     high mass double diffraction amplitude
11114 C                AMPDP(4)   central diffraction amplitude
11115 C
11116 C***********************************************************************
11117       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11118       SAVE
11119
11120       PARAMETER (DEPS  = 1.D-5,
11121      &           EIGHT = 8.D0)
11122
11123 C  input/output channels
11124       INTEGER LI,LO
11125       COMMON /POINOU/ LI,LO
11126 C  event debugging information
11127       INTEGER NMAXD
11128       PARAMETER (NMAXD=100)
11129       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11130      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11131       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11132      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11133 C  model switches and parameters
11134       CHARACTER*8 MDLNA
11135       INTEGER ISWMDL,IPAMDL
11136       DOUBLE PRECISION PARMDL
11137       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11138 C  some constants
11139       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11140       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11141      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11142 C  complex Born graph amplitudes used for unitarization
11143       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
11144      &                AMHMDD,AMPDP
11145       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
11146      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
11147 C  unitarized amplitudes for different diffraction channels
11148       DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
11149      &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
11150      &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
11151      &                 ZXL,BXL
11152       COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
11153      &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
11154      &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
11155      &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
11156      &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
11157      &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
11158      &                ZXL(4,4),BXL(4,4)
11159 C  Reggeon phenomenology parameters
11160       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
11161      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
11162       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
11163      &                ALREG,ALREGP,GR(2),B0REG(2),
11164      &                GPPP,GPPR,B0PPP,B0PPR,
11165      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
11166 C  parameters of 2x2 channel model
11167       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
11168       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
11169 C  global event kinematics and particle IDs
11170       INTEGER IFPAP,IFPAB
11171       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11172       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11173
11174 C  local variables
11175       DIMENSION  AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
11176      &           CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
11177      &           AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
11178       DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
11179
11180 C  combinatorical factors
11181       DATA      CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
11182      &                   1.D0,-1.D0, 1.D0,-1.D0,
11183      &                   1.D0,-1.D0,-1.D0, 1.D0,
11184      &                   1.D0, 1.D0, 1.D0, 1.D0 /
11185       DATA      EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
11186      &                   1.D0,-1.D0,-1.D0, 1.D0,
11187      &                  -1.D0, 1.D0,-1.D0, 1.D0,
11188      &                  -1.D0,-1.D0, 1.D0, 1.D0 /
11189       DATA      IELTAB / 1, 2, 3, 4,
11190      &                   2, 1, 4, 3,
11191      &                   3, 4, 1, 2,
11192      &                   4, 3, 2, 1 /
11193
11194       IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
11195      &  'PHO_CHAN2A: impact parameter B',BB
11196
11197       B24 = BB**2/4.D0
11198       DO 25 I=1,4
11199         AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
11200      &           +ZXR(1,I)*EXP(-B24/BXR(1,I))
11201         AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
11202         AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
11203         AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
11204         AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
11205      &           -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
11206      &           -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
11207         AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
11208         AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
11209         AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
11210         AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
11211  25   CONTINUE
11212
11213       DO 50 I=1,4
11214         ABSUM(I)  = 0.D0
11215         DO 75 II=9,1,-1
11216           ABSUM(I) = ABSUM(I) + AB(II,I)
11217  75     CONTINUE
11218  50   CONTINUE
11219       IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
11220      &  'PHO_CHAN2A: ABSUM',ABSUM
11221
11222       DO 100 I=1,4
11223         CHI(I)  = 0.D0
11224         CHDS(I) = 0.D0
11225         CHDH(I) = 0.D0
11226         CHDA(I) = 0.D0
11227         CHDB(I) = 0.D0
11228         CHDD(I) = 0.D0
11229         CHDPE(I) = 0.D0
11230         CHDPA(I) = 0.D0
11231         CHDPB(I) = 0.D0
11232         CHDPD(I) = 0.D0
11233         AMPELA(I,0) = 0.D0
11234         AMPELA(I,9) = 0.D0
11235         DO 200 K=1,4
11236           AMPELA(I,K) = 0.D0
11237           AMPELA(I,K+4) = 0.D0
11238           AMPVM(I,K)  = 0.D0
11239           CHI(I)  = CHI(I)  + CHIFAC(K,I)*ABSUM(K)
11240           CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
11241           CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
11242           CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
11243           CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
11244           CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
11245           CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
11246           CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
11247           CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
11248           CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
11249  200    CONTINUE
11250         IF(CHI(I).LT.-DEPS) THEN
11251           IF(IDEB(86).GE.0) THEN
11252             WRITE(LO,'(1X,A,I3,2E12.3)')
11253      &        'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
11254             WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
11255           ENDIF
11256         ENDIF
11257         IF(ABS(CHI(I)).GT.200.D0) THEN
11258           EX1CHI(I) = 0.D0
11259           EX2CHI(I) = 0.D0
11260         ELSE
11261           TMP       = EXP(-CHI(I))
11262           EX1CHI(I) = TMP
11263           EX2CHI(I) = TMP*TMP
11264         ENDIF
11265  100  CONTINUE
11266       IF(IDEB(86).GE.20) THEN
11267         WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
11268       ENDIF
11269
11270       AMPELA(1,0) = 4.D0
11271       DO 300 K=1,4
11272         DO 400 J=1,4
11273           CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
11274           AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
11275           AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
11276           AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
11277           AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
11278           AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
11279           AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
11280           AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
11281           AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
11282           AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
11283           AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
11284  400    CONTINUE
11285  300  CONTINUE
11286
11287       IF(IDEB(86).GE.25) THEN
11288         DO 305 I=1,9
11289           WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
11290      &      (AMPELA(K,1),K=1,4)
11291  305    CONTINUE
11292       ENDIF
11293
11294 C  VDM factors --> amplitudes
11295 C  low mass excitations
11296       DO 500 I=1,4
11297         AMPCHA(I) = 0.D0
11298         DO 600 K=1,4
11299           AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
11300  600    CONTINUE
11301  500  CONTINUE
11302       AMPVME    = AMPCHA(1)/EIGHT
11303       AMLMSD(1) = AMPCHA(2)/EIGHT
11304       AMLMSD(2) = AMPCHA(3)/EIGHT
11305       AMLMDD    = AMPCHA(4)/EIGHT
11306 C  elastic part, high mass diffraction
11307       AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
11308       AMPSOF    = 0.D0
11309       AMPHAR    = 0.D0
11310       AMHMSD(1) = 0.D0
11311       AMHMSD(2) = 0.D0
11312       AMHMDD    = 0.D0
11313       AMPDP(1)  = 0.D0
11314       AMPDP(2)  = 0.D0
11315       AMPDP(3)  = 0.D0
11316       AMPDP(4)  = 0.D0
11317       DO 450 I=1,4
11318         AMPEL     = AMPEL     + ELAFAC(I)*AMPELA(I,0)/8.D0
11319         AMPSOF    = AMPSOF    + ELAFAC(I)*AMPELA(I,1)
11320         AMPHAR    = AMPHAR    + ELAFAC(I)*AMPELA(I,2)
11321         AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
11322         AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
11323         AMHMDD    = AMHMDD    + ELAFAC(I)*AMPELA(I,5)
11324         AMPDP(1)  = AMPDP(1)  + ELAFAC(I)*AMPELA(I,6)
11325         AMPDP(2)  = AMPDP(2)  + ELAFAC(I)*AMPELA(I,7)
11326         AMPDP(3)  = AMPDP(3)  + ELAFAC(I)*AMPELA(I,8)
11327         AMPDP(4)  = AMPDP(4)  + ELAFAC(I)*AMPELA(I,9)
11328  450  CONTINUE
11329       AMPSOF    = AMPSOF/16.D0
11330       AMPHAR    = AMPHAR/16.D0
11331       AMHMSD(1) = AMHMSD(1)/16.D0
11332       AMHMSD(2) = AMHMSD(2)/16.D0
11333       AMHMDD    = AMHMDD/16.D0
11334       AMPDP(1)  = AMPDP(1)/16.D0
11335       AMPDP(2)  = AMPDP(2)/16.D0
11336       AMPDP(3)  = AMPDP(3)/16.D0
11337       AMPDP(4)  = AMPDP(4)/16.D0
11338       IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
11339       IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
11340       IF(DREAL(AMHMDD).LE.0.D0)    AMHMDD = 0.D0
11341       IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
11342       IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
11343       IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
11344       IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
11345
11346 C  vector-meson production, weight factors
11347       IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
11348         IF(IFPAP(1).EQ.22) THEN
11349           IF(IFPAP(2).EQ.22) THEN
11350             DO 10 I=1,4
11351               DO 15 J=1,4
11352                 AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
11353  15           CONTINUE
11354  10         CONTINUE
11355           ELSE
11356             AMPVM(1,1) = PARMDL(10)*AMPVME
11357             AMPVM(2,1) = PARMDL(11)*AMPVME
11358             AMPVM(3,1) = PARMDL(12)*AMPVME
11359             AMPVM(4,1) = PARMDL(13)*AMPVME
11360           ENDIF
11361         ELSE IF(IFPAP(2).EQ.22) THEN
11362           AMPVM(1,1) = PARMDL(10)*AMPVME
11363           AMPVM(1,2) = PARMDL(11)*AMPVME
11364           AMPVM(1,3) = PARMDL(12)*AMPVME
11365           AMPVM(1,4) = PARMDL(13)*AMPVME
11366         ENDIF
11367       ENDIF
11368 C  debug output
11369       IF(IDEB(86).GE.5) THEN
11370         WRITE(LO,'(/,1X,A)')
11371      &    'PHO_CHAN2A: impact parameter amplitudes'
11372         WRITE(LO,'(1X,A,1P,2E12.3)') '       AMPEL',AMPEL
11373         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
11374         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
11375         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
11376         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
11377         WRITE(LO,'(1X,A,1P,4E12.3)') '  AMPSOF/HAR',AMPSOF,AMPHAR
11378         WRITE(LO,'(1X,A,1P,4E12.3)') '      AMLMSD',AMLMSD
11379         WRITE(LO,'(1X,A,1P,4E12.3)') '      AMHMSD',AMHMSD
11380         WRITE(LO,'(1X,A,1P,2E12.3)') '      AMLMDD',AMLMDD
11381         WRITE(LO,'(1X,A,1P,2E12.3)') '      AMHMDD',AMHMDD
11382         WRITE(LO,'(1X,A,1P,8E10.3)') '  AMPDP(1-4)',AMPDP
11383       ENDIF
11384
11385       END
11386
11387 CDECK  ID>, PHO_EVENT
11388       SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
11389 C********************************************************************
11390 C
11391 C     main subroutine to manage simulation processes
11392 C
11393 C     input: NEV       -1   initialization
11394 C                       1   generation of events
11395 C                       2   generation of events without rejection
11396 C                           due to energy dependent cross section
11397 C                       3   generation of events without rejection
11398 C                           using initialization energy
11399 C                      -2   output of event generation statistics
11400 C            P1(4)     momentum of particle 1 (internal TARGET)
11401 C            P2(4)     momentum of particle 2 (internal PROJECTILE)
11402 C            FAC       used for initialization:
11403 C                      contains cross section the events corresponds to
11404 C                      during generation: current cross section
11405 C
11406 C     output: IREJ     0: event accepted
11407 C                      1: event rejected
11408 C
11409 C********************************************************************
11410       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11411       SAVE
11412
11413       PARAMETER ( TINY   =  1.D-10 )
11414
11415       DIMENSION P1(4),P2(4)
11416
11417 C  input/output channels
11418       INTEGER LI,LO
11419       COMMON /POINOU/ LI,LO
11420 C  event debugging information
11421       INTEGER NMAXD
11422       PARAMETER (NMAXD=100)
11423       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11424      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11425       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11426      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11427 C  model switches and parameters
11428       CHARACTER*8 MDLNA
11429       INTEGER ISWMDL,IPAMDL
11430       DOUBLE PRECISION PARMDL
11431       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11432 C  general process information
11433       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11434       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11435 C  internal rejection counters
11436       INTEGER NMXJ
11437       PARAMETER (NMXJ=60)
11438       CHARACTER*10 REJTIT
11439       INTEGER IFAIL
11440       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11441 C  gamma-lepton or gamma-hadron vertex information
11442       INTEGER IGHEL,IDPSRC,IDBSRC
11443       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
11444      &                 RADSRC,AMSRC,GAMSRC
11445       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
11446      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
11447      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
11448 C  global event kinematics and particle IDs
11449       INTEGER IFPAP,IFPAB
11450       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11451       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11452 C  cross sections
11453       INTEGER IPFIL,IFAFIL,IFBFIL
11454       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11455      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11456      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11457      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11458      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11459       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11460      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11461      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11462      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11463      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11464      &                IPFIL,IFAFIL,IFBFIL
11465 C  event weights and generated cross section
11466       INTEGER IPOWGC,ISWCUT,IVWGHT
11467       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11468       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11469      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11470 C  names of hard scattering processes
11471       INTEGER Max_pro_1
11472       PARAMETER ( Max_pro_1 = 16 )
11473       CHARACTER*18 PROC
11474       COMMON /POHPRO/ PROC(0:Max_pro_1)
11475 C  hard cross sections and MC selection weights
11476       INTEGER Max_pro_2
11477       PARAMETER ( Max_pro_2 = 16 )
11478       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
11479      &  MH_acc_1,MH_acc_2
11480       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
11481       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
11482      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
11483      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
11484      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
11485      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
11486 C  table of particle indices for recursive PHOJET calls
11487       INTEGER MAXIPX
11488       PARAMETER ( MAXIPX = 100 )
11489       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11490       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11491      &                IPOIX1,IPOIX2,IPOIX3
11492
11493       DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
11494
11495       IREJ = 0
11496
11497 C  initializations
11498       IF(NEV.EQ.-1) THEN
11499         WRITE(LO,'(/3(/1X,A))')
11500      &    '=======================================================',
11501      &    '  ------- initialization of event generation --------',
11502      &    '======================================================='
11503         CALL PHO_SETMDL(0,0,-2)
11504 C  amplitude parameters
11505         CALL PHO_FITPAR(1)
11506
11507         CALL PHO_REJSTA(-1)
11508 C  initialize MC package
11509         CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
11510         CALL PHO_MCINI
11511         CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11512      &    0.D0,-1)
11513         CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
11514
11515 C  cross section
11516         FAC = SIGGEN(4)
11517         DO 20 I=1,10
11518           IPRSAM(I) = 0
11519           IPRACC(I) = 0
11520           IENACC(I) = 0
11521  20     CONTINUE
11522         ISPS = 0
11523         ISPA = 0
11524         ISRS = 0
11525         ISRA = 0
11526         IHPS = 0
11527         IHPA = 0
11528         ISTS = 0
11529         ISTA = 0
11530         ISLS = 0
11531         ISLA = 0
11532         IDIS = 0
11533         IDIA = 0
11534         IDPS = 0
11535         IDPA = 0
11536         IDNS(1) = 0
11537         IDNS(2) = 0
11538         IDNS(3) = 0
11539         IDNS(4) = 0
11540         IDNA(1) = 0
11541         IDNA(2) = 0
11542         IDNA(3) = 0
11543         IDNA(4) = 0
11544         KACCEP = 0
11545         KEVENT = 0
11546         KEVGEN = 0
11547         ECMSUM = 0.D0
11548       ELSE IF(NEV.GT.0) THEN
11549 C
11550 C  -------------- begin event generation ---------------
11551 C
11552         IPAMDL(13) = 0
11553         IF(NEV.EQ.3) IPAMDL(13) = 1
11554         KEVENT = KEVENT+1
11555 C  enable debugging
11556         CALL PHO_TRACE(0,0,0)
11557         IF(IDEB(68).GE.2) THEN
11558           IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
11559      &      WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11560         ENDIF
11561         CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
11562 C  cross section calculation
11563         FAC = SIGGEN(3)
11564         IF(NEV.EQ.1) THEN
11565           IF(IVWGHT(1).EQ.1) THEN
11566             WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
11567           ELSE
11568             WG = SIGGEN(3)/SIGGEN(4)
11569           ENDIF
11570           IF(DT_RNDM(FAC).GT.WG) THEN
11571             IREJ = 1
11572             IF(IDEB(68).GE.6) THEN
11573               WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
11574      &          'PHO_EVENT: rejection due to cross section',
11575      &          ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
11576      &          KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
11577               CALL PHO_PREVNT(-1)
11578             ENDIF
11579             RETURN
11580           ENDIF
11581         ENDIF
11582         KEVGEN = KEVGEN+1
11583         SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
11584         HSWGHT(0) = MAX(1.D0,WG)
11585
11586         ITRY1 = 0
11587  50     CONTINUE
11588           ITRY1 = ITRY1+1
11589           IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11590
11591 C  sample process
11592           IPROCE = 0
11593           CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11594      &      1.D0,IPROCE)
11595           IF(IPROCE.EQ.0) THEN
11596             IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
11597      &        'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
11598             IREJ = 50
11599             RETURN
11600           ENDIF
11601 C  sampling statistics
11602           IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
11603
11604           ITRY2 = 0
11605  60       CONTINUE
11606             ITRY2 = ITRY2+1
11607             IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11608 C  sample number of cut graphs according to IPROCE and
11609 C  generate parton configurations+strings
11610             CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
11611 C  collect statistics
11612             ISPS = ISPS+KSPOM
11613             IHPS = IHPS+KHPOM
11614             ISRS = ISRS+KSREG
11615             ISTS = ISTS+KSTRG+KHTRG
11616             ISLS = ISLS+KSLOO+KHLOO
11617             IDIS = IDIS+MIN(KHDIR,1)
11618             IDPS = IDPS+KHDPO+KSDPO
11619             IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
11620      &        IDNS(KHDIR) = IDNS(KHDIR)+1
11621 C  rejection?
11622           IF(IREJ.NE.0) THEN
11623             IF(IDEB(68).GE.4) THEN
11624               WRITE(LO,'(/1X,A,2I5)')
11625      &          'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
11626               CALL PHO_PREVNT(-1)
11627             ENDIF
11628             IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
11629               RETURN
11630             ENDIF
11631             IFAIL(1) = IFAIL(1)+1
11632             IF(ITRY1.GT.5) RETURN
11633             IF(IREJ.GE.5) THEN
11634               IF(ISWMDL(2).EQ.0) RETURN
11635               GOTO 50
11636             ENDIF
11637             IF(ITRY2.LT.5) GOTO 60
11638             GOTO 50
11639           ENDIF
11640 C  fragmentation of strings
11641
11642 C  FSR and string fragmentation is done separately by DPMJET routines
11643 C         CALL PHO_STRFRA(IREJ)
11644
11645 C  rejection?
11646           IF(IREJ.NE.0) THEN
11647             IFAIL(23) = IFAIL(23)+1
11648             IF(IDEB(68).GE.4)  THEN
11649               WRITE(LO,'(/1X,A,2I5)')
11650      &          'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
11651               CALL PHO_PREVNT(-1)
11652             ENDIF
11653             GOTO 50
11654           ENDIF
11655 C  check of conservation of quantum numbers
11656           IF(IDEB(68).GE.-5) THEN
11657             CALL PHO_CHECK(-1,IREJ)
11658             IF(IREJ.NE.0) GOTO 50
11659           ENDIF
11660 C  event now completely processed and accepted
11661 C  acceptance statistics
11662           IPRACC(IPROCE) = IPRACC(IPROCE)+1
11663           ISPA = ISPA+KSPOM
11664           IHPA = IHPA+KHPOM
11665           ISRA = ISRA+KSREG
11666           ISTA = ISTA+(KSTRG+KHTRG)
11667           ISLA = ISLA+(KSLOO+KHLOO)
11668           IDIA = IDIA+MIN(KHDIR,1)
11669           IDPA = IDPA+KHDPO+KSDPO
11670           IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
11671      &      IDNA(KHDIR) = IDNA(KHDIR)+1
11672           DO 55 I=1,IPOIX2
11673             IENACC(IPORES(I)) = IENACC(IPORES(I))+1
11674  55       CONTINUE
11675           KACCEP = KACCEP+1
11676
11677 C  debug output (partial / full event listing)
11678           if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
11679      &      WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11680           IF(IDEB(67).GE.10) THEN
11681             IF(IDEB(67).LE.15) THEN
11682               CALL PHO_PREVNT(-1)
11683             ELSE IF(IDEB(67).LE.20) THEN
11684               CALL PHO_PREVNT(0)
11685             ELSE IF(IDEB(67).LE.25) THEN
11686               CALL PHO_PREVNT(1)
11687             ELSE
11688               CALL PHO_PREVNT(2)
11689             ENDIF
11690           ENDIF
11691 C
11692 C  effective weight
11693           DO 65 I=1,10
11694             IF(IPOWGC(I).GT.0) THEN
11695               HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
11696             ENDIF
11697  65       CONTINUE
11698           IF(IVWGHT(1).EQ.1) THEN
11699             WG = HSWGHT(0)
11700             IF(WG.GT.1.01D0) THEN
11701               IF(EVWGHT(1).LT.1.01D0) THEN
11702                 WRITE(LO,'(1X,A,2I12,1PE12.3)')
11703      &            'PHO_EVENT: cross section weight > 1',
11704      &            KEVENT,KACCEP,WG
11705                 WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
11706      &            SIGGEN(3),SIGGEN(4),EVWGHT(1)
11707               ENDIF
11708               EVWGHT(1) = HSWGHT(0)
11709               HSWGHT(0) = 1.D0
11710             ELSE
11711               EVWGHT(1) = 1.D0
11712             ENDIF
11713           ENDIF
11714
11715 C  effective cross section
11716           SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
11717           ECMSUM = ECMSUM+ECM
11718           SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
11719       ELSE IF(NEV.EQ.-2) THEN
11720
11721 C  ---------------- end of event generation ----------------------
11722
11723 * --- Commented by Chiara
11724 *        WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
11725 *     &    '====================================================',
11726 *     &    '  --------- summary of event generation ----------',
11727 *     &    '====================================================',
11728 *     &    'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
11729 *     &    'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
11730
11731 C  write out statistics
11732         IF(KACCEP.GT.0) THEN
11733
11734           FAC1 = SIGGEN(4)/DBLE(KEVENT)
11735           FAC2 = FAC/DBLE(KACCEP)
11736 *          WRITE(LO,'(/1X,A,/1X,A)')
11737 *     &      'PHO_EVENT: generated and accepted events',
11738 *     &      '----------------------------------------'
11739 *          WRITE(LO,'(3X,A)')
11740 *     &   'process, sampled, accepted, cross section (internal/external)'
11741 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
11742 *     &      IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
11743 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
11744 *     &      IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
11745 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
11746 *     &      IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
11747 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
11748 *     &      IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
11749 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
11750 *     &      IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
11751 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
11752 *     &      IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
11753 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
11754 *     &      IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
11755 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all  ',IPRSAM(8),
11756 *     &      IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
11757 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
11758 *     &      DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
11759 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
11760 *     &      DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
11761 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
11762 *     &      DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
11763 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
11764 *     &      DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
11765 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
11766 *     &      DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
11767 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
11768 *     &      DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
11769 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
11770 *     &      DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
11771 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
11772 *     &      DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
11773 *          WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
11774 *     &      DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
11775 C *** commented by Chiara
11776 C          IF(ISWMDL(14).GT.0) THEN
11777 C            WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
11778 C     &        ISWMDL(14)
11779 C            WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
11780 C            WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
11781 C            WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
11782 C            WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
11783 C            WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
11784 C          ENDIF
11785 *          WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
11786 *     &      SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
11787
11788           CALL PHO_REJSTA(-2)
11789           CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11790      &      0.D0,-2)
11791           CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
11792 C  statistics of hard scattering processes
11793 *          WRITE(LO,'(2(/1X,A))')
11794 *     &      'PHO_EVENT: statistics of hard scattering processes',
11795 *     &      '--------------------------------------------------'
11796 *          DO 43 K=1,4
11797 *            IF(MH_tried(0,K).GT.0) THEN
11798 *              WRITE(LO,'(/5X,A,I3)')
11799 *     &      'process (accepted,x-section internal/external) for IP:',K
11800 *              DO 47 M=0,Max_pro_2
11801 *                WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
11802 *     &            MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
11803 *     &            DBLE(MH_acc_2(M,K))*FAC2
11804 * 47           CONTINUE
11805 *            ENDIF
11806 * 43       CONTINUE
11807
11808         ELSE
11809           WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
11810         ENDIF
11811 *        WRITE(LO,'(/3(/1X,A)/)')
11812 *     &    '======================================================',
11813 *     &    '   ------- end of event generation summary --------',
11814 *     &    '======================================================'
11815       ELSE
11816         WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
11817       ENDIF
11818
11819       END
11820
11821 CDECK  ID>, PHO_PARTON
11822       SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
11823 C********************************************************************
11824 C
11825 C     calculation of complete parton configuration
11826 C
11827 C     input:  IPROC   process ID  1 nondiffractive
11828 C                                 2 elastic
11829 C                                 3 quasi-ela. rho,omega,phi prod.
11830 C                                 4 double Pomeron
11831 C                                 5 single diff 1
11832 C                                 6 single diff 2
11833 C                                 7 double diff diss.
11834 C                                 8 single-resolved / direct photon
11835 C             JM1,2   index of mother particles in /POEVT1/
11836 C
11837 C
11838 C     output: complete parton configuration in /POEVT1/
11839 C             IREJ                1 failure
11840 C                                 0 success
11841 C                                50 rejection due to user cutoffs
11842 C
11843 C********************************************************************
11844       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11845       SAVE
11846
11847       DIMENSION P1(4),P2(4)
11848
11849       PARAMETER ( TINY   =  1.D-10 )
11850
11851 C  input/output channels
11852       INTEGER LI,LO
11853       COMMON /POINOU/ LI,LO
11854 C  event debugging information
11855       INTEGER NMAXD
11856       PARAMETER (NMAXD=100)
11857       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11858      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11859       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11860      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11861 C  model switches and parameters
11862       CHARACTER*8 MDLNA
11863       INTEGER ISWMDL,IPAMDL
11864       DOUBLE PRECISION PARMDL
11865       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11866 C  table of particle indices for recursive PHOJET calls
11867       INTEGER MAXIPX
11868       PARAMETER ( MAXIPX = 100 )
11869       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11870       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11871      &                IPOIX1,IPOIX2,IPOIX3
11872 C  general process information
11873       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11874       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11875 C  global event kinematics and particle IDs
11876       INTEGER IFPAP,IFPAB
11877       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11878       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11879 C  cross sections
11880       INTEGER IPFIL,IFAFIL,IFBFIL
11881       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11882      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11883      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11884      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11885      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11886       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11887      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11888      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11889      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11890      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11891      &                IPFIL,IFAFIL,IFBFIL
11892 C  event weights and generated cross section
11893       INTEGER IPOWGC,ISWCUT,IVWGHT
11894       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11895       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11896      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11897 C  internal rejection counters
11898       INTEGER NMXJ
11899       PARAMETER (NMXJ=60)
11900       CHARACTER*10 REJTIT
11901       INTEGER IFAIL
11902       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11903
11904       IREJ = 0
11905 C  clear event statistics
11906       KSPOM = 0
11907       KHPOM = 0
11908       KSREG = 0
11909       KHDIR = 0
11910       KSTRG = 0
11911       KHTRG = 0
11912       KSLOO = 0
11913       KHLOO = 0
11914       KHARD = 0
11915       KSOFT = 0
11916       KSDPO = 0
11917       KHDPO = 0
11918
11919 C-------------------------------------------------------------------
11920 C  nondiffractive resolved processes
11921
11922       IF(IPROC.EQ.1) THEN
11923 C  sample number of interactions
11924  555    CONTINUE
11925         IINT = 0
11926         IP   = 1
11927 C  generate only hard events
11928         IF(ISWMDL(2).EQ.0) THEN
11929           MHPOM = 1
11930           MSPOM = 0
11931           MSREG = 0
11932           MHDIR = 0
11933           HSWGHT(1) = 1.D0
11934         ELSE
11935 C  minimum bias events
11936           IPOWGC(1) = 0
11937  10       CONTINUE
11938           CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
11939           IPOWGC(1) = IPOWGC(1)+1
11940           MINT = 0
11941           MHDIR = 0
11942           MSTRG = 0
11943           MSLOO = 0
11944 C
11945 C  resolved soft processes: pomeron and reggeon
11946           MSPOM = IINT
11947           MSREG = JINT
11948 C  resolved hard process: hard pomeron
11949           MHPOM = KINT
11950 C  resolved absorptive corrections
11951           MPTRI = 0
11952           MPLOO = 0
11953 C  restrictions given by user
11954           IF(MSPOM.LT.ISWCUT(1)) GOTO 10
11955           IF(MSREG.LT.ISWCUT(2)) GOTO 10
11956           IF(MHPOM.LT.ISWCUT(3)) GOTO 10
11957           HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
11958 C  ----------------------------
11959           IF(ISWMDL(15).EQ.0) THEN
11960             MHPOM = 0
11961             IF(MSREG.GT.0) THEN
11962               MSPOM = 0
11963               MSREG = 1
11964             ELSE
11965               MSPOM = 1
11966               MSREG = 0
11967             ENDIF
11968           ELSE IF(ISWMDL(15).EQ.1) THEN
11969             IF(MHPOM.GT.0) THEN
11970               MHPOM = 1
11971               MSPOM = 0
11972               MSREG = 0
11973             ELSE IF(MSPOM.GT.0) THEN
11974               MSPOM = 1
11975               MSREG = 0
11976             ELSE
11977               MSREG = 1
11978             ENDIF
11979           ELSE IF(ISWMDL(15).EQ.2) THEN
11980             MHPOM = MIN(1,MHPOM)
11981           ELSE IF(ISWMDL(15).EQ.3) THEN
11982             MSPOM = MIN(1,MSPOM)
11983           ENDIF
11984         ENDIF
11985 C  ----------------------------
11986
11987 C  statistics
11988         ISPS = ISPS+MSPOM
11989         IHPS = IHPS+MHPOM
11990         ISRS = ISRS+MSREG
11991         ISTS = ISTS+MSTRG
11992         ISLS = ISLS+MSLOO
11993
11994         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
11995      &    'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
11996      &    KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
11997
11998         ITRY2 = 0
11999  50     CONTINUE
12000         ITRY2 = ITRY2+1
12001         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12002         KSPOM = MSPOM
12003         KSREG = MSREG
12004         KHPOM = MHPOM
12005         KHDIR = MHDIR
12006         KSTRG = MPTRI
12007         KSLOO = MPLOO
12008
12009         CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12010         IF(IREJ.NE.0) THEN
12011           IF(IREJ.EQ.50) RETURN
12012           IF(IDEB(3).GE.2) THEN
12013             WRITE(LO,'(/1X,A,I5)')
12014      &        'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
12015             CALL PHO_PREVNT(-1)
12016           ENDIF
12017           RETURN
12018         ENDIF
12019         IF(MHPOM.GT.0) THEN
12020           IDNODF = 3
12021         ELSE IF(MSPOM.GT.0) THEN
12022           IDNODF = 2
12023         ELSE
12024           IDNODF = 1
12025         ENDIF
12026 C  check of quantum numbers of parton configurations
12027         IF(IDEB(3).GE.0) THEN
12028           CALL PHO_CHECK(1,IREJ)
12029           IF(IREJ.NE.0) GOTO 50
12030         ENDIF
12031 C  sample strings to prepare fragmentation
12032         CALL PHO_STRING(1,IREJ)
12033         IF(IREJ.NE.0) THEN
12034           IF(IREJ.EQ.50) RETURN
12035           IFAIL(30) = IFAIL(30)+1
12036           IF(IDEB(3).GE.2)  THEN
12037             WRITE(LO,'(/1X,A,I5)')
12038      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12039             CALL PHO_PREVNT(-1)
12040           ENDIF
12041           IF(ITRY2.LT.20) GOTO 50
12042           IF(IDEB(3).GE.1) THEN
12043             WRITE(LO,'(/1X,A,I5)')
12044      &        'PHO_PARTON: rejection',ITRY2
12045             CALL PHO_PREVNT(-1)
12046           ENDIF
12047           RETURN
12048         ENDIF
12049
12050 C  statistics
12051         ISPA = ISPA+KSPOM
12052         IHPA = IHPA+KHPOM
12053         ISRA = ISRA+KSREG
12054         ISTA = ISTA+KSTRG
12055         ISLA = ISLA+KSLOO
12056
12057 C-------------------------------------------------------------------
12058 C  elastic scattering / quasi-elastic rho/omega/phi production
12059
12060       ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12061         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12062      &    'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12063
12064 C  DPMJET call with special projectile / target: transform into CMS
12065         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12066      &    CALL PHO_DFWRAP(1,JM1,JM2)
12067
12068         CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12069
12070         IF(IREJ.NE.0) THEN
12071 C  DPMJET call with special projectile / target: clean up
12072           IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12073      &      CALL PHO_DFWRAP(-2,JM1,JM2)
12074           IF(IDEB(3).GE.2) THEN
12075             WRITE(LO,'(/1X,A,I5)')
12076      &        'PHO_PARTON: rejection by PHO_QELAST',IREJ
12077             CALL PHO_PREVNT(-1)
12078           ENDIF
12079           RETURN
12080         ENDIF
12081
12082 C  DPMJET call with special projectile / target: transform back
12083         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12084      &    CALL PHO_DFWRAP(2,JM1,JM2)
12085
12086 C  prepare possible decays
12087         CALL PHO_STRING(1,IREJ)
12088         IF(IREJ.NE.0) THEN
12089           IF(IREJ.EQ.50) RETURN
12090           IFAIL(30) = IFAIL(30)+1
12091           RETURN
12092         ENDIF
12093
12094 C---------------------------------------------------------------------
12095 C  double Pomeron scattering
12096
12097       ELSE IF(IPROC.EQ.4) THEN
12098         MSOFT = 0
12099         MHARD = 0
12100         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12101      &      'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12102         IDPS = IDPS+1
12103         ITRY2 = 0
12104  60     CONTINUE
12105         ITRY2 = ITRY2+1
12106         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12107 C
12108         CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12109         IF(IREJ.NE.0) THEN
12110           IF(IDEB(3).GE.2) THEN
12111             WRITE(LO,'(/1X,A,I5)')
12112      &        'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12113             CALL PHO_PREVNT(-1)
12114           ENDIF
12115           RETURN
12116         ENDIF
12117 C  check of quantum numbers of parton configurations
12118         IF(IDEB(3).GE.0) THEN
12119           CALL PHO_CHECK(1,IREJ)
12120           IF(IREJ.NE.0) GOTO 60
12121         ENDIF
12122 C  sample strings to prepare fragmentation
12123         CALL PHO_STRING(1,IREJ)
12124         IF(IREJ.NE.0) THEN
12125           IF(IREJ.EQ.50) RETURN
12126           IFAIL(30) = IFAIL(30)+1
12127           IF(IDEB(3).GE.2) THEN
12128             WRITE(LO,'(/1X,A,I5)')
12129      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12130             CALL PHO_PREVNT(-1)
12131           ENDIF
12132           IF(ITRY2.LT.10) GOTO 60
12133           WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12134           CALL PHO_PREVNT(-1)
12135           RETURN
12136         ENDIF
12137         IDPA = IDPA+1
12138
12139 C-----------------------------------------------------------------------
12140 C  single / double diffraction dissociation
12141
12142       ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12143         MSOFT = 0
12144         MHARD = 0
12145         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12146      &    'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12147         IF(IPROC.EQ.5) ID1S = ID1S+1
12148         IF(IPROC.EQ.6) ID2S = ID2S+1
12149         IF(IPROC.EQ.7) ID3S = ID3S+1
12150         ITRY2 = 0
12151  70     CONTINUE
12152         ITRY2 = ITRY2+1
12153         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12154         IPAR1 = 1
12155         IPAR2 = 1
12156         IF(IPROC.EQ.5) IPAR2 = 0
12157         IF(IPROC.EQ.6) IPAR1 = 0
12158 C  calculate rapidity gap survival probability
12159         SPROB = 1.D0
12160         IF(ECM.GT.10.D0) THEN
12161           IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12162             IF(SIGTR1(1).LT.1.D-10) THEN
12163               SPROB = 1.D0
12164             ELSE
12165               SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12166             ENDIF
12167           ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12168             IF(SIGTR2(1).LT.1.D-10) THEN
12169               SPROB = 1.D0
12170             ELSE
12171               SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12172             ENDIF
12173           ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12174             IF(SIGLOO.LT.1.D-10) THEN
12175               SPROB = 1.D0
12176             ELSE
12177               SPROB = SIGHDD/SIGLOO
12178             ENDIF
12179           ENDIF
12180         ENDIF
12181
12182 **sr
12183 * temporary patch, r.e. 8.6.99
12184         SPROB = 1.D0
12185 **
12186
12187 C  DPMJET call with special projectile / target: transform into CMS
12188         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12189      &    CALL PHO_DFWRAP(1,JM1,JM2)
12190
12191         CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12192
12193         IF(IREJ.NE.0) THEN
12194 C  DPMJET call with special projectile / target: clean up
12195           IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12196      &      CALL PHO_DFWRAP(-2,JM1,JM2)
12197           IF(IDEB(3).GE.2) THEN
12198             WRITE(LO,'(/1X,A,I5)')
12199      &        'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12200             CALL PHO_PREVNT(-1)
12201           ENDIF
12202           RETURN
12203         ENDIF
12204
12205 C  DPMJET call with special projectile / target: transform back
12206         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12207      &    CALL PHO_DFWRAP(2,JM1,JM2)
12208
12209 C  check of quantum numbers of parton configurations
12210         IF(IDEB(3).GE.0) THEN
12211           CALL PHO_CHECK(1,IREJ)
12212           IF(IREJ.NE.0) GOTO 70
12213         ENDIF
12214 C  sample strings to prepare fragmentation
12215         CALL PHO_STRING(1,IREJ)
12216         IF(IREJ.NE.0) THEN
12217           IF(IREJ.EQ.50) RETURN
12218           IFAIL(30) = IFAIL(30)+1
12219           IF(IDEB(3).GE.2) THEN
12220             WRITE(LO,'(/1X,A,I5)')
12221      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12222             CALL PHO_PREVNT(-1)
12223           ENDIF
12224           IF(ITRY2.LT.10) GOTO 70
12225           WRITE(LO,'(/1X,A,I5)')
12226      &      'PHO_PARTON: rejection',ITRY2
12227           CALL PHO_PREVNT(-1)
12228           RETURN
12229         ENDIF
12230         IF(IPROC.EQ.5) ID1A = ID1A+1
12231         IF(IPROC.EQ.6) ID2A = ID2A+1
12232         IF(IPROC.EQ.7) ID3A = ID3A+1
12233
12234 C-----------------------------------------------------------------------
12235 C  single / double direct processes
12236
12237       ELSE IF(IPROC.EQ.8) THEN
12238         MSREG = 0
12239         MSPOM = 0
12240         MHPOM = 0
12241         MHDIR = 1
12242         IF(IDEB(3).GE.5) THEN
12243           WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12244         ENDIF
12245         IDIS = IDIS+MHDIR
12246         ITRY2 = 0
12247  80     CONTINUE
12248         ITRY2 = ITRY2+1
12249         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12250         KSPOM = MSPOM
12251         KSREG = MSREG
12252         KHPOM = MHPOM
12253         KHDIR = 4
12254
12255         CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12256         IF(IREJ.NE.0) THEN
12257           IF(IREJ.EQ.50) RETURN
12258           IF(IDEB(3).GE.2) THEN
12259             WRITE(LO,'(/1X,A,I5)')
12260      &        'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12261             CALL PHO_PREVNT(-1)
12262           ENDIF
12263           RETURN
12264         ENDIF
12265         IDNODF = 4
12266 C  check of quantum numbers of parton configurations
12267         IF(IDEB(3).GE.0) THEN
12268           CALL PHO_CHECK(1,IREJ)
12269           IF(IREJ.NE.0) GOTO 80
12270         ENDIF
12271 C  sample strings to prepare fragmentation
12272         CALL PHO_STRING(1,IREJ)
12273         IF(IREJ.NE.0) THEN
12274           IF(IREJ.EQ.50) RETURN
12275           IFAIL(30) = IFAIL(30)+1
12276           IF(IDEB(3).GE.2) THEN
12277             WRITE(LO,'(/1X,A,I5)')
12278      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12279             CALL PHO_PREVNT(-1)
12280           ENDIF
12281           IF(ITRY2.LT.10) GOTO 80
12282           WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12283           CALL PHO_PREVNT(-1)
12284           RETURN
12285         ENDIF
12286         IF(IPROC.EQ.5) ID1A = ID1A+1
12287         IF(IPROC.EQ.6) ID2A = ID2A+1
12288         IF(IPROC.EQ.7) ID3A = ID3A+1
12289         IDIA = IDIA+MHDIR
12290
12291 C-----------------------------------------------------------------------
12292 C  initialize control statistics
12293
12294       ELSE IF(IPROC.EQ.-1) THEN
12295         CALL PHO_SAMPRB(ECM,-1,0,0,0)
12296         CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12297         CALL PHO_SEAFLA(-1,0,0,DUM)
12298         IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12299      &    CALL PHO_QELAST(-1,1,2,0)
12300         ISPS = 0
12301         ISPA = 0
12302         ISRS = 0
12303         ISRA = 0
12304         IHPS = 0
12305         IHPA = 0
12306         ISTS = 0
12307         ISTA = 0
12308         ISLS = 0
12309         ISLA = 0
12310         ID1S = 0
12311         ID1A = 0
12312         ID2S = 0
12313         ID2A = 0
12314         ID3S = 0
12315         ID3A = 0
12316         IDPS = 0
12317         IDPA = 0
12318         IDIS = 0
12319         IDIA = 0
12320         CALL PHO_STRING(-1,IREJ)
12321         CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12322         RETURN
12323
12324 C-----------------------------------------------------------------------
12325 C  produce statistics summary
12326
12327       ELSE IF(IPROC.EQ.-2) THEN
12328         IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12329 C        IF(IDEB(3).GE.0) THEN
12330 C *** Commented by Chiara
12331 C          WRITE(LO,'(/1X,A,/1X,A)')
12332 C     &      'PHO_PARTON: internal statistics on parton configurations',
12333 C     &      '--------------------------------------------------------'
12334 C          WRITE(LO,'(5X,A)') 'process          sampled      accepted'
12335 C          WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12336 C          WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12337 C          WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12338 C          WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12339 C          WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12340 C          WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12341 C          WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12342 C          WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12343 C          WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12344 C          WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12345 C        ENDIF
12346         CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12347         IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12348      &    CALL PHO_QELAST(-2,1,2,0)
12349         CALL PHO_STRING(-2,IREJ)
12350         CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12351         CALL PHO_SEAFLA(-2,0,0,DUM)
12352         RETURN
12353       ELSE
12354         WRITE(LO,'(1X,A,I2)')
12355      &    'PARTON:ERROR: unknown process ID ',IPROC
12356         STOP
12357       ENDIF
12358
12359       END
12360
12361 CDECK  ID>, PHO_MCINI
12362       SUBROUTINE PHO_MCINI
12363 C********************************************************************
12364 C
12365 C     initialization of MC event generation
12366 C
12367 C********************************************************************
12368       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12369       SAVE
12370
12371       PARAMETER ( PIMASS =  0.13D0,
12372      &            TINY   =  1.D-10 )
12373
12374 C  input/output channels
12375       INTEGER LI,LO
12376       COMMON /POINOU/ LI,LO
12377 C  event debugging information
12378       INTEGER NMAXD
12379       PARAMETER (NMAXD=100)
12380       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12381      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12382       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12383      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12384 C  model switches and parameters
12385       CHARACTER*8 MDLNA
12386       INTEGER ISWMDL,IPAMDL
12387       DOUBLE PRECISION PARMDL
12388       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12389 C  general process information
12390       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12391       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12392 C  cross sections
12393       INTEGER IPFIL,IFAFIL,IFBFIL
12394       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12395      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12396      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12397      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12398      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12399       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12400      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12401      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12402      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12403      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12404      &                IPFIL,IFAFIL,IFBFIL
12405 C  hard cross sections and MC selection weights
12406       INTEGER Max_pro_2
12407       PARAMETER ( Max_pro_2 = 16 )
12408       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12409      &  MH_acc_1,MH_acc_2
12410       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12411       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12412      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12413      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12414      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12415      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12416 C  interpolation tables for hard cross section and MC selection weights
12417       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12418       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12419       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12420       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12421      &  HQ2a_tab,HQ2b_tab,HEcm_tab
12422       COMMON /POHTAB/
12423      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12424      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12425      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12426      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12427      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12428      &  HEcm_tab(1:Max_tab_E,0:4),
12429      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12430 C  global event kinematics and particle IDs
12431       INTEGER IFPAP,IFPAB
12432       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12433       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12434 C  obsolete cut-off information
12435       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12436       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12437 C  event weights and generated cross section
12438       INTEGER IPOWGC,ISWCUT,IVWGHT
12439       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12440       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12441      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12442 C  cut probability distribution
12443       INTEGER IEETA1,IIMAX,KKMAX
12444       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12445       INTEGER IEEMAX,IMAX,KMAX
12446       REAL PROB
12447       DOUBLE PRECISION EPTAB
12448       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12449      &                IEEMAX,IMAX,KMAX
12450 C  energy-interpolation table
12451       INTEGER IEETA2
12452       PARAMETER ( IEETA2 = 20 )
12453       INTEGER ISIMAX
12454       DOUBLE PRECISION SIGTAB,SIGECM
12455       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12456
12457       CHARACTER*15 PHO_PNAME
12458       DIMENSION ECMF(4)
12459
12460       DATA  XMPOM / 0.766D0 /
12461
12462 C  initialize fragmentation
12463       CALL PHO_FRAINI(ISWMDL(6))
12464
12465 C  reset interpolation tables
12466       DO 50 I=1,4
12467         DO 60 J=1,10
12468           DO 70 K=1,70
12469             SIGTAB(I,K,J) = 0.D0
12470  70       CONTINUE
12471           SIGECM(I,J) = 0.D0
12472  60     CONTINUE
12473  50   CONTINUE
12474
12475 C  max. number of allowed colors (large N expansion)
12476       IC1 = 0
12477       IC2 = 10000
12478       CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12479
12480 C  lower energy limit of initialization
12481       ETABLO = PARMDL(19)
12482       IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12483
12484 C *** Commented by Chiara
12485 C      WRITE(LO,'(/,1X,A,2F12.1)')
12486 C     &  'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12487 C      WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12488 C     &  'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12489 C     &  PMASS(1),PVIRT(1)
12490 C      WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12491 C     &  'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12492 C     &  PMASS(2),PVIRT(2)
12493
12494 C  cuts on probabilities of multiple interactions
12495       IMAX = MIN(IPAMDL(32),IIMAX)
12496       KMAX = MIN(IPAMDL(33),KKMAX)
12497       AH = 2.D0*PTCUT(1)/ECM
12498       IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12499       KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12500
12501 C  hard interpolation table
12502       ECMF(1) = ECM
12503       ECMF(2) = 0.9D0*ECMF(1)
12504       ECMF(3) = ECMF(2)
12505       ECMF(4) = ECMF(2)
12506       do k=1,4
12507         IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12508         IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12509         IF(ECMF(k).LT.50.D0)  IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12510         IF(ECMF(k).LT.10.D0)  IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12511       enddo
12512
12513 C  initialization of hard scattering for all channels and cutoffs
12514       IF(HSWCUT(5).GT.PARMDL(36))  CALL PHO_HARMCI(-1,ECMF(1))
12515       I0 = 4
12516       IF(ISWMDL(2).EQ.0) I0 = 1
12517       DO 110 I=I0,1,-1
12518         CALL PHO_HARMCI(I,ECMF(I))
12519  110  CONTINUE
12520
12521 C  dimension of interpolation table of cut probabilities
12522       IEEMAX = MIN(IPAMDL(31),IEETA1)
12523       IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12524       IF(ECM.LT.50.D0)  IEEMAX = MIN(IEEMAX,10)
12525       IF(ECM.LT.10.D0)  IEEMAX = MIN(IEEMAX,5)
12526       ISIMAX = IEEMAX
12527
12528 C  calculate probability distribution
12529       I0 = 4
12530       IFT1 = IFPAP(1)
12531       IFT2 = IFPAP(2)
12532       XMT1 = PMASS(1)
12533       XMT2 = PMASS(2)
12534       XVT1 = PVIRT(1)
12535       XVT2 = PVIRT(2)
12536       IF(ISWMDL(2).EQ.0) I0 = 1
12537       DO 150 IP=I0,1,-1
12538       ECMPRO = ECMF(IP)*1.001D0
12539       IF(IP.EQ.4) THEN
12540         IFPAP(1) = 990
12541         IFPAP(2) = 990
12542         PMASS(1) = XMPOM
12543         PMASS(2) = XMPOM
12544         PVIRT(1) = 0.D0
12545         PVIRT(2) = 0.D0
12546       ELSE IF(IP.EQ.3) THEN
12547         IFPAP(1) = IFT2
12548         IFPAP(2) = 990
12549         PMASS(1) = XMT2
12550         PMASS(2) = XMPOM
12551         PVIRT(1) = XVT2
12552         PVIRT(2) = 0.D0
12553       ELSE IF(IP.EQ.2) THEN
12554         IFPAP(1) = IFT1
12555         IFPAP(2) = 990
12556         PMASS(1) = XMT1
12557         PMASS(2) = XMPOM
12558         PVIRT(1) = XVT1
12559         PVIRT(2) = 0.D0
12560       ELSE
12561         IFPAP(1) = IFT1
12562         IFPAP(2) = IFT2
12563         PMASS(1) = XMT1
12564         PMASS(2) = XMT2
12565         PVIRT(1) = XVT1
12566         PVIRT(2) = XVT2
12567       ENDIF
12568       IF(IEEMAX.GT.1) THEN
12569         IF(IP.EQ.1) THEN
12570           ELMIN = LOG(ETABLO)
12571         ELSE
12572           ELMIN = LOG(2.5D0)
12573         ENDIF
12574         EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12575         DO 100 I=1,IEEMAX
12576           ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12577           CALL PHO_PRBDIS(IP,ECMPRO,I)
12578  100    CONTINUE
12579       ELSE
12580         CALL PHO_PRBDIS(IP,ECMPRO,1)
12581       ENDIF
12582
12583 C  debug output of cross section tables
12584       IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12585       IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12586 * --- Commented by Chiara
12587 *      WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12588 *     &'Table of total cross sections (mb) for particle combination',IP,
12589 *     &' Ecm    SIGtot  SIGela  SIGine  SIGqel  SIGsd1  SIGsd2  SIGdd',
12590 *     &'-------------------------------------------------------------'
12591 *      DO 200 I=1,IEEMAX
12592 *        WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12593 *     &    SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12594 *     &    SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12595 *     &    SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12596 *     &    SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12597 * 200  CONTINUE
12598  201  CONTINUE
12599       IF(IDEB(62).GE.2) THEN
12600       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12601      &'Table of partial x-sections (mb) for particle combination',IP,
12602      &' Ecm    SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL  SIGDDH  SIGCDF',
12603      &'--------------------------------------------------------------'
12604       DO 205 I=1,IEEMAX
12605         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12606      &    SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12607      &    SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12608  205  CONTINUE
12609       ENDIF
12610       IF(IDEB(62).GE.2) THEN
12611       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12612      &'Table of born graph x-sections (mb) for particle combination',IP,
12613      &' Ecm    SIGSVDM SIGHRES SIGHDIR SIGTR1  SIGTR2  SIGLOO SIGDPO',
12614      &'-------------------------------------------------------------'
12615       DO 210 I=1,IEEMAX
12616         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12617      &    SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12618      &    SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12619      &    SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12620      &    SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12621      &    +SIGTAB(IP,68,I)
12622  210  CONTINUE
12623       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12624      &'Table of unitarized x-sections (mb) for particle combination',IP,
12625      &' Ecm    SIGSVDM SIGHVDM  SIGTR1  SIGTR2  SIGLOO SIGDPO  SLOPE',
12626      &'-------------------------------------------------------------'
12627       DO 215 I=1,IEEMAX
12628         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12629      &    SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12630      &    SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12631  215  CONTINUE
12632       ENDIF
12633       IF(IDEB(62).GE.1) THEN
12634       WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12635      &'Table of expected average number of cuts in non-diff events:',
12636      &'       for max. number of cuts soft/hard:',IMAX,KMAX,
12637      &' Ecm   PTCUT   SIGNDF   POM-S   POM-H   REG-S',
12638      &'---------------------------------------------'
12639       DO 220 I=1,IEEMAX
12640         WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12641      &    SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12642      &    SIGTAB(IP,76,I)
12643  220  CONTINUE
12644       IF(IP.EQ.1) THEN
12645         WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12646      &  'Table of rapidity gap survival probability (high-mass diff.):',
12647      &  ' Ecm    Spro-sd1     Spro-sd2    Spro-dd    Spro-cd',
12648      &  '---------------------------------------------------'
12649         DO 230 I=1,IEEMAX
12650           IF(SIGECM(IP,I).GT.10.D0) THEN
12651             SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12652      &               -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12653             SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12654      &               -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12655             SPRDD  = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12656      &               +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12657      &               +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12658             SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12659      &               +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12660             WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12661      &        SPRSD1,SPRSD2,SPRDD,SPRCDF
12662           ENDIF
12663  230    CONTINUE
12664       ENDIF
12665       ENDIF
12666       ENDIF
12667  150  CONTINUE
12668
12669 C  simulate only hard scatterings
12670       IF(ISWMDL(2).EQ.0) THEN
12671         WRITE(LO,'(2(/1X,A))')
12672      &    'WARNING: generation of hard scatterings only!',
12673      &    '============================================='
12674         DO 151 I=2,7
12675           IPRON(I,1) = 0
12676  151    CONTINUE
12677         DO 152 K=2,4
12678           DO 153 I=1,15
12679             IPRON(I,K) = 0
12680  153      CONTINUE
12681  152    CONTINUE
12682         SIGGEN(4) = 0.D0
12683         DO 160 I=1,IEEMAX
12684           SIGMAX = 0.D0
12685           IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12686           IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12687           IF(SIGMAX.GT.SIGGEN(4)) THEN
12688             ISIGM = I
12689             SIGGEN(4) = SIGMAX
12690           ENDIF
12691  160    CONTINUE
12692       ELSE
12693 * --- Commented by Chiara
12694 *        WRITE(LO,'(2(/1X,A))')
12695 *     &    'activated processes, cross section',
12696 *     &    '----------------------------------'
12697 *        WRITE(LO,'(5X,A,I3,2X,3I3)')
12698 *     &    '  nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12699 *        WRITE(LO,'(5X,A,I3,2X,3I3)')
12700 *     &    '            elastic scattering',(IPRON(2,K),K=1,4)
12701 *        WRITE(LO,'(5X,A,I3,2X,3I3)')
12702 *     &    'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12703 *        WRITE(LO,'(5X,A,I3,2X,3I3)')
12704 *     &    '      double pomeron processes',(IPRON(4,K),K=1,4)
12705 *        WRITE(LO,'(5X,A,I3,2X,3I3)')
12706 *     &    ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12707 *        WRITE(LO,'(5X,A,I3,2X,3I3)')
12708 *     &    ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12709 *        WRITE(LO,'(5X,A,I3,2X,3I3)')
12710 *     &    '    double diffract. processes',(IPRON(7,K),K=1,4)
12711 *        WRITE(LO,'(5X,A,I3,2X,3I3)')
12712 *     &    '       direct photon processes',(IPRON(8,K),K=1,4)
12713
12714 C  calculate effective cross section
12715         SIGGEN(4) = 0.D0
12716         DO 165 I=1,IEEMAX
12717           CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12718      &                PVIRT(1),PVIRT(2))
12719           SIGMAX = 0.D0
12720           if(iswmdl(2).ge.1) then
12721             IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12722      &        -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12723      &        -SIGLDD-SIGHDD-SIGDIR
12724             IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12725             IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12726             IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12727             IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12728             IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12729             IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12730             IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12731           else
12732             IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12733             IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12734           endif
12735           IF(SIGMAX.GT.SIGGEN(4)) THEN
12736             ISIGM = I
12737             SIGGEN(4) = SIGMAX
12738           ENDIF
12739  165    CONTINUE
12740       ENDIF
12741
12742 C  debug output
12743       IF(SIGGEN(4).LT.1.D-20) THEN
12744         WRITE(LO,'(//1X,A)')
12745      &  'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12746         STOP
12747       ENDIF
12748       WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12749      &  SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12750       WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12751
12752       END
12753
12754 CDECK  ID>, PHO_REJSTA
12755       SUBROUTINE PHO_REJSTA(IMODE)
12756 C********************************************************************
12757 C
12758 C     MC rejection counting
12759 C
12760 C     input IMODE    -1   initialization
12761 C                    -2   output of statistics
12762 C
12763 C********************************************************************
12764
12765       IMPLICIT NONE
12766
12767       SAVE
12768
12769 C  input/output channels
12770       INTEGER LI,LO
12771       COMMON /POINOU/ LI,LO
12772 C  event debugging information
12773       INTEGER NMAXD
12774       PARAMETER (NMAXD=100)
12775       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12776      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12777       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12778      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12779 C  internal rejection counters
12780       INTEGER NMXJ
12781       PARAMETER (NMXJ=60)
12782       CHARACTER*10 REJTIT
12783       INTEGER IFAIL
12784       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12785
12786       INTEGER IMODE
12787
12788       INTEGER I
12789
12790 C  initialization
12791       IF(IMODE.EQ.-1) THEN
12792         DO 100 I=1,NMXJ
12793           IFAIL(I) = 0
12794  100    CONTINUE
12795 C
12796         REJTIT(1)  = 'PARTON ALL'
12797         REJTIT(2)  = 'STDPAR ALL'
12798         REJTIT(3)  = 'STDPAR DPO'
12799         REJTIT(4)  = 'POMSCA ALL'
12800         REJTIT(5)  = 'POMSCA INT'
12801         REJTIT(6)  = 'POMSCA KIN'
12802         REJTIT(7)  = 'DIFDIS ALL'
12803         REJTIT(8)  = 'POSPOM ALL'
12804         REJTIT(9)  = 'HRES.DIF.1'
12805         REJTIT(10) = 'HDIR.DIF.1'
12806         REJTIT(11) = 'HRES.DIF.2'
12807         REJTIT(12) = 'HDIR.DIF.2'
12808         REJTIT(13) = 'DIFDIS INT'
12809         REJTIT(14) = 'HADRON SP2'
12810         REJTIT(15) = 'HADRON SP3'
12811         REJTIT(16) = 'HARDIR ALL'
12812         REJTIT(17) = 'HARDIR INT'
12813         REJTIT(18) = 'HARDIR KIN'
12814         REJTIT(19) = 'MCHECK BAR'
12815         REJTIT(20) = 'MCHECK MES'
12816         REJTIT(21) = 'DIF.DISS.1'
12817         REJTIT(22) = 'DIF.DISS.2'
12818         REJTIT(23) = 'STRFRA ALL'
12819         REJTIT(24) = 'MSHELL CHA'
12820         REJTIT(25) = 'PARTPT SOF'
12821         REJTIT(26) = 'PARTPT HAR'
12822         REJTIT(27) = 'INTRINS KT'
12823         REJTIT(28) = 'HACHEK DIR'
12824         REJTIT(29) = 'HACHEK RES'
12825         REJTIT(30) = 'STRING ALL'
12826         REJTIT(31) = 'POMSCA INT'
12827         REJTIT(32) = 'DIFF SLOPE'
12828         REJTIT(33) = 'GLU2QU ALL'
12829         REJTIT(34) = 'MASCOR ALL'
12830         REJTIT(35) = 'PARCOR ALL'
12831         REJTIT(36) = 'MSHELL PAR'
12832         REJTIT(37) = 'MSHELL ALL'
12833         REJTIT(38) = 'POMCOR ALL'
12834         REJTIT(39) = 'DB-POM KIN'
12835         REJTIT(40) = 'DB-POM ALL'
12836         REJTIT(41) = 'SOFTXX ALL'
12837         REJTIT(42) = 'SOFTXX PSP'
12838
12839 C  write output
12840 * --- Commented by Chiara
12841 *      ELSE IF(IMODE.EQ.-2) THEN
12842 *        WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12843 *     &                             '--------------------------------'
12844 *        DO 300 I=1,NMXJ
12845 *          IF(IFAIL(I).GT.0)
12846 *     &      WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12847 * 300    CONTINUE
12848 *      ELSE
12849 *        WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12850       ENDIF
12851
12852       END
12853
12854 CDECK  ID>, PHO_POSPOM
12855       SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12856 C***********************************************************************
12857 C
12858 C     registration of one cut pomeron (soft/semihard)
12859 C
12860 C     input:   IP      particle combination the pomeron belongs to
12861 C              IND1,2  position of X values in /POSOFT/
12862 C                      1 corresponds to a valence-pomeron
12863 C              IGEN    production process of mother particles
12864 C              IPOM    pomeron number
12865 C              KCUT    total number of cut pomerons and reggeons
12866 C
12867 C     output:  ISWAP   exchange of x values
12868 C              IND1,2  increased by the number of partons belonging
12869 C                      to the generated pomeron cut
12870 C              IREJ    success/failure
12871 C
12872 C**********************************************************************
12873       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12874       SAVE
12875
12876       PARAMETER ( DEPS   =  1.D-8 )
12877
12878 C  input/output channels
12879       INTEGER LI,LO
12880       COMMON /POINOU/ LI,LO
12881 C  event debugging information
12882       INTEGER NMAXD
12883       PARAMETER (NMAXD=100)
12884       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12885      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12886       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12887      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12888 C  internal rejection counters
12889       INTEGER NMXJ
12890       PARAMETER (NMXJ=60)
12891       CHARACTER*10 REJTIT
12892       INTEGER IFAIL
12893       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12894 C  model switches and parameters
12895       CHARACTER*8 MDLNA
12896       INTEGER ISWMDL,IPAMDL
12897       DOUBLE PRECISION PARMDL
12898       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12899 C  general process information
12900       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12901       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12902 C  global event kinematics and particle IDs
12903       INTEGER IFPAP,IFPAB
12904       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12905       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12906 C  data of c.m. system of Pomeron / Reggeon exchange
12907       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12908       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12909      &                 SIDP,CODP,SIFP,COFP
12910       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12911      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
12912      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
12913 C  obsolete cut-off information
12914       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12915       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12916 C  energy-interpolation table
12917       INTEGER IEETA2
12918       PARAMETER ( IEETA2 = 20 )
12919       INTEGER ISIMAX
12920       DOUBLE PRECISION SIGTAB,SIGECM
12921       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12922 C  light-cone x fractions and c.m. momenta of soft cut string ends
12923       INTEGER MAXSOF
12924       PARAMETER ( MAXSOF = 50 )
12925       INTEGER IJSI2,IJSI1
12926       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12927       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12928      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12929      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
12930
12931 C  standard particle data interface
12932       INTEGER NMXHEP
12933
12934       PARAMETER (NMXHEP=4000)
12935
12936       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
12937       DOUBLE PRECISION PHEP,VHEP
12938       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
12939      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
12940      &                VHEP(4,NMXHEP)
12941 C  extension to standard particle data interface (PHOJET specific)
12942       INTEGER IMPART,IPHIST,ICOLOR
12943       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
12944
12945 C  table of particle indices for recursive PHOJET calls
12946       INTEGER MAXIPX
12947       PARAMETER ( MAXIPX = 100 )
12948       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
12949       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
12950      &                IPOIX1,IPOIX2,IPOIX3
12951
12952       DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
12953
12954       IREJ = 0
12955       ISWAP = 0
12956       JM1 = NPOSP(1)
12957       JM2 = NPOSP(2)
12958       INDX1 = IND1
12959       INDX2 = IND2
12960       EA1 = XS1(IND1)*ECMP/2.D0
12961       EA2 = XS1(IND1+1)*ECMP/2.D0
12962       EB1 = XS2(IND2)*ECMP/2.D0
12963       EB2 = XS2(IND2+1)*ECMP/2.D0
12964       CMASS1 = MIN(EA1,EA2)
12965       CMASS2 = MIN(EB1,EB2)
12966
12967 C  debug output
12968       IF(IDEB(9).GE.20) THEN
12969         WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
12970      &    'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
12971         WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
12972      &    CMASS1,CMASS2
12973       ENDIF
12974
12975 C  flavours
12976       IF(IND1.EQ.1) THEN
12977         CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
12978       ELSE
12979         CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
12980       ENDIF
12981       IF(IND2.EQ.1) THEN
12982         CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
12983       ELSE
12984         CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
12985       ENDIF
12986       DO 75 I=1,4
12987         P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
12988         P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
12989  75   CONTINUE
12990
12991 C  pomeron resolved?
12992       IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
12993 C  find energy for cross section calculation
12994         IF(IPAMDL(16).EQ.2) THEN
12995           ESUB = ECMP
12996         ELSE IF(IPAMDL(16).EQ.3) THEN
12997           IF(IPROCE.EQ.1) THEN
12998             ESUB = ECM
12999           ELSE
13000             ESUB = ECMP
13001           ENDIF
13002         ELSE
13003           ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
13004      &                -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
13005         ENDIF
13006 C  load cross sections from interpolation table
13007         IF(ESUB.LE.SIGECM(IP,1)) THEN
13008           I1 = 1
13009           I2 = 2
13010         ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
13011           DO 50 I=2,ISIMAX
13012             IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
13013  50       CONTINUE
13014  200      CONTINUE
13015           I1 = I-1
13016           I2 = I
13017         ELSE
13018           WRITE(LO,'(/1X,A,2E12.3)')
13019      &      'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
13020           CALL PHO_PREVNT(-1)
13021           I1 = ISIMAX-1
13022           I2 = ISIMAX
13023         ENDIF
13024         FAC2=0.D0
13025         IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
13026      &                    /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
13027         FAC1=1.D0-FAC2
13028 C  calculate weights
13029 *       WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13030 *       WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13031 *       WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13032 *       WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13033 *       WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13034 *       WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13035
13036         WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13037      &          +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13038         WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13039         WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13040         WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13041      &                 +SIGTAB(IP,64,I2))
13042      &          +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13043      &                 +SIGTAB(IP,64,I1))
13044         WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13045      &                 +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13046      &          +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13047      &                 +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13048
13049 C  one-pomeron cut
13050         WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13051 C  central diff. cut
13052         WGX(2) = WGXCDF
13053 C  diff. diss. of particle 1
13054         WGX(3) = WGXHSD(1)
13055 C  diff. diss. of particle 2
13056         WGX(4) = WGXHSD(2)
13057 C  double diff. dissociation
13058         WGX(5) = WGXHDD
13059 C  two-pomeron cut
13060         WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13061
13062 *       IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13063 *         WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13064 *    &      ' unitarity bound reached for ',IP,ESUB,WGX(1)
13065 *         WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13066 *         WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13067 *         WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13068 *       ENDIF
13069
13070         SUM  = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13071
13072 C  selection loop
13073  205    CONTINUE
13074         XI = DT_RNDM(SUM)*SUM
13075         I = 0
13076         SUM = 0.D0
13077  210    CONTINUE
13078           I = I+1
13079           SUM = SUM+WGX(I)
13080         IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13081 C  phase space correction
13082         IF(I.NE.1) THEN
13083           ISAM = 4
13084           IF(I.EQ.6) ISAM = 8
13085           PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13086 *         IF(DT_RNDM(SUM).GT.PACC) I=1
13087           IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13088         ENDIF
13089
13090 C  do not generate diffraction for events with only one cut pomeron
13091         IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13092
13093 C  do not generate recursive calls for remants with
13094 C  diquark-anti-diquark flavour contents
13095         if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13096         if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13097
13098 C  debug output
13099         IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13100      &    'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13101
13102         IF(I.GT.1) THEN
13103 C  second scattering needed
13104           CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13105           CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13106           IDPD1 = IPHO_ID2PDG(IDHA1)
13107           IDPD2 = IPHO_ID2PDG(IDHA2)
13108
13109           if(INDX1.eq.1) then
13110             if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13111      &        IGEN_had = IGEN
13112           else
13113             IGEN_had = -IGEN
13114           endif
13115           CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13116      &      IPOM,IGEN_had,0,0,IPOS1,1)
13117
13118           if(INDX2.eq.1) then
13119             if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13120      &        IGEN_had = IGEN
13121           else
13122             IGEN_had = -IGEN
13123           endif
13124           CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13125      &      IPOM,IGEN_had,0,0,IPOS1,1)
13126
13127           IND1 = IND1+2
13128           IND2 = IND2+2
13129 C  update index
13130           IPOIX2 = IPOIX2+1
13131
13132           IF(IPOIX2.GT.MAXIPX) THEN
13133             WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13134      &        '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13135             IREJ = 1
13136             RETURN
13137           ENDIF
13138
13139           IPORES(IPOIX2) = I+2
13140           IPOPOS(1,IPOIX2) = IPOS1-1
13141           IPOPOS(2,IPOIX2) = IPOS1
13142           RETURN
13143         ENDIF
13144       ENDIF
13145
13146  100  CONTINUE
13147       IF(ISWMDL(12).EQ.0) THEN
13148 C  sample colors
13149         CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13150         CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13151
13152 C  purely gluonic pomeron or sea strings formed by gluons
13153
13154         IF(    ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13155      &     .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13156           IFLA1 = 21
13157           IFLA2 = 21
13158         ENDIF
13159         IF(    ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13160      &     .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13161           IFLB1 = 21
13162           IFLB2 = 21
13163         ENDIF
13164
13165 C  color connection
13166         IF(IFLA1.NE.21) THEN
13167           IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13168      &      .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13169      &      CALL PHO_SWAPI(ICA1,ICD1)
13170         ENDIF
13171         IF(IFLB1.NE.21) THEN
13172           IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13173      &      .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13174      &      CALL PHO_SWAPI(ICB1,ICC1)
13175         ENDIF
13176         ISWAP = 0
13177         IF(ICA1*ICB1.GT.0) THEN
13178           IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13179             IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13180               CALL PHO_SWAPI(IFLA1,IFLA2)
13181               CALL PHO_SWAPI(ICA1,ICD1)
13182             ELSE
13183               CALL PHO_SWAPI(IFLB1,IFLB2)
13184               CALL PHO_SWAPI(ICB1,ICC1)
13185             ENDIF
13186           ELSE IF(IND1.NE.1) THEN
13187             CALL PHO_SWAPI(IFLA1,IFLA2)
13188             CALL PHO_SWAPI(ICA1,ICD1)
13189           ELSE IF(IND2.NE.1) THEN
13190             CALL PHO_SWAPI(IFLB1,IFLB2)
13191             CALL PHO_SWAPI(ICB1,ICC1)
13192           ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13193             IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13194               CALL PHO_SWAPI(IFLA1,IFLA2)
13195               CALL PHO_SWAPI(ICA1,ICD1)
13196             ELSE
13197               CALL PHO_SWAPI(IFLB1,IFLB2)
13198               CALL PHO_SWAPI(ICB1,ICC1)
13199             ENDIF
13200           ELSE IF(IFLA1.EQ.-IFLA2) THEN
13201             CALL PHO_SWAPI(IFLA1,IFLA2)
13202             CALL PHO_SWAPI(ICA1,ICD1)
13203           ELSE IF(IFLB1.EQ.-IFLB2) THEN
13204             CALL PHO_SWAPI(IFLB1,IFLB2)
13205             CALL PHO_SWAPI(ICB1,ICC1)
13206           ELSE
13207             ISWAP = 1
13208             IF(IDEB(9).GE.5) THEN
13209               WRITE(LO,'(1X,A,I12)')
13210      &          'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13211                 WRITE(LO,'(5X,A,4I7)')
13212      &          'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13213               WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13214             ENDIF
13215           ENDIF
13216         ENDIF
13217
13218 C  registration
13219
13220 C  purely gluonic pomeron or sea strings formed by gluons
13221         IF(IFLA1.EQ.21) THEN
13222           CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13223      &      IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13224           IND1 = IND1+2
13225
13226 C  strings formed by quarks
13227         ELSE
13228 C  valence quark labels
13229           IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13230      &       .and.(IDHEP(JM1).NE.990)) THEN
13231             ICA2 = 1
13232             ICD2 = 1
13233           ENDIF
13234 C  registration
13235           CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13236      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13237      &      ICA2,IPOS1,1)
13238           IND1 = IND1+1
13239           CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13240      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13241      &      ICD2,IPOS,1)
13242           IND1 = IND1+1
13243
13244         ENDIF
13245
13246 C  purely gluonic pomeron or sea strings formed by gluons
13247         IF(IFLB1.EQ.21) THEN
13248           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13249      &      IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13250           IND2 = IND2+2
13251
13252 C  strings formed by quarks
13253         ELSE
13254 C  valence quark labels
13255           IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13256      &       .and.(IDHEP(JM2).NE.990)) THEN
13257             ICB2 = 1
13258             ICC2 = 1
13259           ENDIF
13260 C  registration
13261           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13262      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13263      &      ICB2,IPOS,1)
13264           IND2 = IND2+1
13265           CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13266      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13267      &      ICC2,IPOS2,1)
13268           IND2 = IND2+1
13269
13270         ENDIF
13271
13272 C  soft pt assignment
13273         IF(ISWMDL(18).EQ.0) THEN
13274           CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13275           IF(IREJ.NE.0) THEN
13276             IFAIL(25) = IFAIL(25)+1
13277             RETURN
13278           ENDIF
13279         ENDIF
13280       ELSE
13281 *       CALL PHO_BFKL(P1,P2,IPART,IREJ)
13282 *       IF(IREJ.NE.0) RETURN
13283       ENDIF
13284
13285       END
13286
13287 CDECK  ID>, PHO_HADSP2
13288       SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13289 C***********************************************************************
13290 C
13291 C     split hadron momentum XMAX into two partons using
13292 C     lower cut-off: AS
13293 C
13294 C     input:   IFLB    compressed particle code of particle to split
13295 C              XS1     sum of x values already selected
13296 C              XMAX    maximal x possible
13297 C
13298 C     output:  XS1     new sum of x values (without first one)
13299 C              XSOFT1  field of selected x values
13300 C
13301 C**********************************************************************
13302       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13303       SAVE
13304
13305       PARAMETER ( DEPS   =  1.D-8 )
13306
13307       DIMENSION XSOFT1(50)
13308
13309 C  input/output channels
13310       INTEGER LI,LO
13311       COMMON /POINOU/ LI,LO
13312 C  event debugging information
13313       INTEGER NMAXD
13314       PARAMETER (NMAXD=100)
13315       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13316      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13317       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13318      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13319 C  internal rejection counters
13320       INTEGER NMXJ
13321       PARAMETER (NMXJ=60)
13322       CHARACTER*10 REJTIT
13323       INTEGER IFAIL
13324       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13325 C  data on most recent hard scattering
13326       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13327       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13328      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13329      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13330       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13331      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13332      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13333      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13334      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13335
13336 C  model exponents
13337       DATA PVMES1 /-0.5D0/
13338       DATA PVMES2 /-0.5D0/
13339       DATA PVBAR1 / 1.5D0/
13340       DATA PVBAR2 /-0.5D0/
13341 C
13342       IREJ = 0
13343       ITMAX = 100
13344 C
13345 C  mesonic particle
13346       IF(ipho_bar3(IFLB,0).EQ.0) THEN
13347         XPOT1 = PVMES1+1.D0
13348         XPOT2 = PVMES2+1.D0
13349 C  baryonic particle
13350       ELSE
13351         XPOT1 = PVBAR1+1.D0
13352         XPOT2 = PVBAR2+1.D0
13353       ENDIF
13354       ITER = 0
13355       XREST= 1.D0-XS1
13356 C  selection loop
13357  100  CONTINUE
13358         ITER = ITER+1
13359         IF(ITER.GE.ITMAX) THEN
13360           IF(IDEB(39).GE.3) THEN
13361             WRITE(LO,'(1X,A,I8)')
13362      &        'PHO_HADSP2: REJECTION (ITER)',ITER
13363             WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13364           ENDIF
13365           IFAIL(14) = IFAIL(14)+1
13366           IREJ = 1
13367           RETURN
13368         ENDIF
13369         ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13370       IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13371       XSS1 = XS1 + ZZ
13372       IF((1.D0-XSS1).LT.AS) GOTO 100
13373 C
13374       XS1 = XSS1
13375       XSOFT1(1) = 1.D0-XSS1
13376       XSOFT1(2) = ZZ
13377 C  debug output
13378       IF(IDEB(39).GE.10) THEN
13379         WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13380         WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS  X1,X2:',
13381      &    XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13382       ENDIF
13383       END
13384
13385 CDECK  ID>, PHO_HADSP3
13386       SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13387 C***********************************************************************
13388 C
13389 C     split hadron momentum XMAX into diquark & quark pair
13390 C     using lower cut-off: AS
13391 C
13392 C     input:   IFLB    compressed particle code of particle to split
13393 C              XS1     sum of x values already selected
13394 C              XMAX    maximal x possible
13395 C
13396 C     output:  XS1     new sum of x values
13397 C              XSOFT1  field of selected x values
13398 C
13399 C
13400 C**********************************************************************
13401       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13402       SAVE
13403       PARAMETER ( DEPS   =  1.D-8 )
13404
13405       DIMENSION XSOFT1(50),XSOFT2(50)
13406
13407 C  input/output channels
13408       INTEGER LI,LO
13409       COMMON /POINOU/ LI,LO
13410 C  event debugging information
13411       INTEGER NMAXD
13412       PARAMETER (NMAXD=100)
13413       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13414      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13415       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13416      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13417 C  internal rejection counters
13418       INTEGER NMXJ
13419       PARAMETER (NMXJ=60)
13420       CHARACTER*10 REJTIT
13421       INTEGER IFAIL
13422       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13423 C  data of c.m. system of Pomeron / Reggeon exchange
13424       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13425       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13426      &                 SIDP,CODP,SIFP,COFP
13427       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13428      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
13429      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
13430
13431       DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13432
13433 C  model exponents
13434       DATA PVMES1 /-0.5D0/
13435       DATA PVMES2 /-0.5D0/
13436       DATA PSMES  /-0.99D0/
13437       DATA PVBAR1 / 1.5D0/
13438       DATA PVBAR2 /-0.5D0/
13439       DATA PSBAR  /-0.99D0/
13440 C
13441       IREJ = 0
13442 C
13443 C  determine exponents
13444 C  particle 1
13445 C
13446       XMMIN = 0.3D0/ECMP
13447       XBMIN = 1.6D0/ECMP
13448 C  mesonic particle
13449       IF(ipho_bar3(IFLB,0).EQ.0) THEN
13450         XPOT1(1) = PVMES1
13451         XMIN(1,1)  = XMMIN
13452         XPOT1(2) = PVMES2
13453         XMIN(1,2)  = XMMIN
13454         XPOT1(3) = PSMES
13455         XMIN(1,3)  = XMMIN
13456 C  baryonic particle
13457       ELSE
13458         XPOT1(1) = PVBAR1
13459         XMIN(1,1)  = XBMIN
13460         XPOT1(2) = PVBAR2
13461         XMIN(1,2)  = XMMIN
13462         XPOT1(3) = PSBAR
13463         XMIN(1,3)  = XMMIN
13464       ENDIF
13465 C  particle 2
13466 C  mesonic particle
13467       XPOT2(1) = PVMES1
13468       XMIN(2,1)  = XMMIN
13469       XPOT2(2) = PVMES2
13470       XMIN(2,2)  = XMMIN
13471       XPOT2(3) = PSMES
13472       XMIN(2,3)  = XMMIN
13473 C
13474       XDUM1 = 0.01D0
13475       XDUM2 = 0.99D0
13476       CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13477      &            XSOFT1,XSOFT2,IREJ)
13478 C  rejection?
13479       IF(IREJ.NE.0) THEN
13480         IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13481      &    'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13482         IFAIL(15) = IFAIL(15)+1
13483         IREJ = 1
13484         RETURN
13485       ENDIF
13486 C  debug output
13487       IF(IDEB(74).GE.10) THEN
13488         WRITE(LO,'(1X,A,I6,2E12.4)')
13489      &    'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13490         DO 100 I=1,3
13491           WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13492  100    CONTINUE
13493       ENDIF
13494
13495       END
13496
13497 CDECK  ID>, PHO_SOFTXX
13498       SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13499      &                  XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13500 C***********************************************************************
13501 C
13502 C    select soft x values
13503 C
13504 C    input:   JM1,JM2    mother particle index in POEVT1
13505 C                        (0  flavour not known before)
13506 C             MSPAR1,2   number of x values to select
13507 C             IVAL1,2    number valence quarks involved in hard
13508 C                        scattering (0,1,2)
13509 C             MSM1,2     minimum number of soft x to get sampled
13510 C             XSUM1,2    sum of all x values samples up this call
13511 C             XMAX1,2    max. x value
13512 C
13513 C    output   XSUM1,2    new sum of x-values sampled
13514 C             XS1,2      field containing sampled x values
13515 C
13516 C    x values of valence partons are first given
13517 C
13518 C***********************************************************************
13519       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13520       SAVE
13521
13522 C  input/output channels
13523       INTEGER LI,LO
13524       COMMON /POINOU/ LI,LO
13525 C  event debugging information
13526       INTEGER NMAXD
13527       PARAMETER (NMAXD=100)
13528       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13529      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13530       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13531      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13532 C  internal rejection counters
13533       INTEGER NMXJ
13534       PARAMETER (NMXJ=60)
13535       CHARACTER*10 REJTIT
13536       INTEGER IFAIL
13537       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13538 C  model switches and parameters
13539       CHARACTER*8 MDLNA
13540       INTEGER ISWMDL,IPAMDL
13541       DOUBLE PRECISION PARMDL
13542       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13543 C  data of c.m. system of Pomeron / Reggeon exchange
13544       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13545       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13546      &                 SIDP,CODP,SIFP,COFP
13547       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13548      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
13549      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
13550
13551 C  standard particle data interface
13552       INTEGER NMXHEP
13553
13554       PARAMETER (NMXHEP=4000)
13555
13556       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13557       DOUBLE PRECISION PHEP,VHEP
13558       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13559      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13560      &                VHEP(4,NMXHEP)
13561 C  extension to standard particle data interface (PHOJET specific)
13562       INTEGER IMPART,IPHIST,ICOLOR
13563       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13564
13565 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
13566       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13567       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13568       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13569      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13570 C  obsolete cut-off information
13571       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13572       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13573 C  data on most recent hard scattering
13574       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13575       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13576      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13577      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13578       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13579      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13580      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13581      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13582      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13583
13584       DIMENSION XS1(*),XS2(*)
13585
13586       INTEGER MAXPOT
13587       PARAMETER ( MAXPOT = 50 )
13588       DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13589
13590       IREJ = 0
13591
13592       MSMAX = MAX(MSPAR1,MSPAR2)
13593       MSMIN = MAX(MSM1,MSM2)
13594
13595       IF(MSMAX.GT.MAXPOT) THEN
13596         WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13597      &    'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13598         IREJ = 1
13599         RETURN
13600       ENDIF
13601
13602 C  determine exponents
13603       IBAR1 = ipho_bar3(JM1,2)
13604       IBAR2 = ipho_bar3(JM2,2)
13605       ISWAP = 0
13606       IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13607 C  meson-baryon scattering (asymmetric sea)
13608       IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13609         PSBAR = PARMDL(53)
13610         PSMES = PARMDL(57)
13611       ELSE
13612         PSBAR = PARMDL(52)
13613         PSMES = PARMDL(56)
13614       ENDIF
13615
13616 C  lower limits for x sampling
13617       XMMINA = 2.D0*PARMDL(157)/ECMP
13618       XBMINA = 2.D0*PARMDL(158)/ECMP
13619       XSMINA = 2.D0*PARMDL(159)/ECMP
13620       XMIN1 = MAX(XSOMIN,AS/XMAX2)
13621       XMIN2 = MAX(XSOMIN,AS/XMAX1)
13622       XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13623       XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13624       XMIN1 = MAX(AS/XMAX2,XMIN1)
13625       XMIN2 = MAX(AS/XMAX1,XMIN2)
13626
13627 C  particle 1
13628       XMMIN1 = MAX(XMIN1,XMMINA)
13629       XBMIN1 = MAX(XMIN1,XBMINA)
13630       XSMIN1 = MAX(XMIN1,XSMINA)
13631 C  mesonic particle
13632       IF(IBAR1.EQ.0) THEN
13633         IF(IHFLS(1).EQ.0) THEN
13634           XPOT1(1) = PARMDL(62)
13635           XMIN(1,1)  = XSMIN1
13636           XPOT1(2) = PARMDL(63)
13637           XMIN(1,2)  = XSMIN1
13638         ELSE
13639           XPOT1(1) = PARMDL(54)
13640           XMIN(1,1)  = XMMIN1
13641           XPOT1(2) = PARMDL(55)
13642           XMIN(1,2)  = XMMIN1
13643         ENDIF
13644         DO 100 I=3-IVAL1,MSMAX
13645           XPOT1(I) = PSMES
13646           XMIN(1,I)  = XSMIN1
13647  100    CONTINUE
13648 C  baryonic particle
13649       ELSE
13650         IF(IHFLS(1).EQ.0) THEN
13651           XPOT1(1) = PARMDL(62)
13652           XMIN(1,1)  = XSMIN1
13653           XPOT1(2) = PARMDL(63)
13654           XMIN(1,2)  = XSMIN1
13655         ELSE
13656           XPOT1(1) = PARMDL(50)
13657           XMIN(1,1)  = XBMIN1
13658           XPOT1(2) = PARMDL(51)
13659           XMIN(1,2)  = XMMIN1
13660         ENDIF
13661         DO 200 I=3-IVAL1,MSMAX
13662           XPOT1(I) = PSBAR
13663           XMIN(1,I)  = XSMIN1
13664  200    CONTINUE
13665       ENDIF
13666
13667 C  particle 2
13668       XMMIN2 = MAX(XMIN2,XMMINA)
13669       XBMIN2 = MAX(XMIN2,XBMINA)
13670       XSMIN2 = MAX(XMIN2,XSMINA)
13671 C  mesonic particle
13672       IF(IBAR2.EQ.0) THEN
13673         IF(IHFLS(2).EQ.0) THEN
13674           XPOT2(1) = PARMDL(62)
13675           XMIN(2,1)  = XSMIN2
13676           XPOT2(2) = PARMDL(63)
13677           XMIN(2,2)  = XSMIN2
13678         ELSE
13679           XPOT2(1) = PARMDL(54)
13680           XMIN(2,1)  = XMMIN2
13681           XPOT2(2) = PARMDL(55)
13682           XMIN(2,2)  = XMMIN2
13683         ENDIF
13684         DO 300 I=3-IVAL2,MSMAX
13685           XPOT2(I) = PSMES
13686           XMIN(2,I)  = XSMIN2
13687  300    CONTINUE
13688 C  baryonic particle
13689       ELSE
13690         IF(IHFLS(2).EQ.0) THEN
13691           XPOT2(1) = PARMDL(62)
13692           XMIN(2,1)  = XSMIN2
13693           XPOT2(2) = PARMDL(63)
13694           XMIN(2,2)  = XSMIN2
13695         ELSE
13696           XPOT2(1) = PARMDL(50)
13697           XMIN(2,1)  = XBMIN2
13698           XPOT2(2) = PARMDL(51)
13699           XMIN(2,2)  = XMMIN2
13700         ENDIF
13701         DO 400 I=3-IVAL2,MSMAX
13702           XPOT2(I) = PSBAR
13703           XMIN(2,I)  = XSMIN2
13704  400    CONTINUE
13705       ENDIF
13706
13707       XSS1 = XSUM1
13708       XSS2 = XSUM2
13709       MSOFT = MSMAX
13710
13711 C  check limits (important for valences)
13712       IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13713       IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13714
13715       XMINS1 = XSS1
13716       IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13717       XMINS2 = XSS2
13718       IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13719       DO 10 I=1,MSOFT
13720         XMINS1 = XMINS1+XMIN(1,I)
13721         XMINS2 = XMINS2+XMIN(2,I)
13722  10   CONTINUE
13723       IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13724
13725 C  try to sample x values
13726       IF(IPAMDL(14).EQ.0) THEN
13727         IF(MSOFT.EQ.2) THEN
13728           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13729      &                XS1,XS2,IREJ)
13730         ELSE IF(MSOFT.LT.5) THEN
13731           CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13732      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13733         ELSE
13734           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13735      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13736         ENDIF
13737       ELSE IF(IPAMDL(14).EQ.1) THEN
13738         IF(MSOFT.EQ.2) THEN
13739           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13740      &                XS1,XS2,IREJ)
13741         ELSE
13742           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13743      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13744         ENDIF
13745       ELSE IF(IPAMDL(14).EQ.2) THEN
13746         CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13747      &              XMAXP1,XMAXP2,XS1,XS2,IREJ)
13748       ELSE IF(IPAMDL(14).EQ.3) THEN
13749         IF(MSOFT.EQ.2) THEN
13750           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13751      &                XS1,XS2,IREJ)
13752         ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13753           CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13754      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13755         ELSE
13756           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13757      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13758         ENDIF
13759       ELSE
13760         WRITE(LO,'(/,1X,A,I3)')
13761      &    'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13762         STOP
13763       ENDIF
13764       IF(IREJ.NE.0) THEN
13765         IFAIL(41) = IFAIL(41)+1
13766         IF(IDEB(60).GE.2) THEN
13767           WRITE(LO,'(1X,A,I12,4I3)')
13768      &      'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13769      &      KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13770           WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13771      &      XSUM1,XSUM2,XMAX1,XMAX2
13772         ENDIF
13773         RETURN
13774       ENDIF
13775       IF(MSOFT.NE.MSMAX) THEN
13776         MSDIFF = MSMAX-MSOFT
13777         MSPAR1 = MSPAR1-MSDIFF
13778         MSPAR2 = MSPAR2-MSDIFF
13779       ENDIF
13780
13781 C  correct for different MSPAR numbers
13782       IF(MSOFT.NE.MSPAR1) THEN
13783         IF(MSPAR1.GT.1) THEN
13784           XDEL = 0.D0
13785           DO 500 I=MSPAR1+1,MSOFT
13786             XDEL = XDEL+XS1(I)
13787  500      CONTINUE
13788           XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13789           DO 550 I=2,MSPAR1
13790             XS1(I) = XS1(I)*XFAC
13791  550      CONTINUE
13792           XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13793         ELSE
13794           XSS1 = XSUM1
13795         ENDIF
13796       ENDIF
13797       IF(MSOFT.NE.MSPAR2) THEN
13798         IF(MSPAR2.GT.1) THEN
13799           XDEL = 0.D0
13800           DO 600 I=MSPAR2+1,MSOFT
13801             XDEL = XDEL+XS2(I)
13802  600      CONTINUE
13803           XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13804           DO 650 I=2,MSPAR2
13805             XS2(I) = XS2(I)*XFAC
13806  650      CONTINUE
13807           XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13808         ELSE
13809           XSS2 = XSUM2
13810         ENDIF
13811       ENDIF
13812
13813 C  first x entry
13814       XS1(1) = 1.D0 - XSS1
13815       XS2(1) = 1.D0 - XSS2
13816       XSUM1 = XSS1
13817       XSUM2 = XSS2
13818
13819 C  debug output
13820       IF(IDEB(60).GE.10) THEN
13821         WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13822      &    'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13823      &    KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13824         WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I  XS1/2   XPOT1/2  XMIN1/2'
13825         DO 30 I=1,MSOFT
13826           WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13827      &      XMIN(1,I),XMIN(2,I)
13828  30     CONTINUE
13829       ENDIF
13830
13831       RETURN
13832
13833 C  not enough phase space
13834  1000 CONTINUE
13835
13836       IFAIL(42) = IFAIL(42)+1
13837       IREJ = 1
13838
13839 C  warning message
13840       IF(IDEB(60).GE.1) THEN
13841         WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13842      &    'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13843      &    ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13844      &    XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13845         WRITE(LO,'(1X,A,1P,3E11.3)')
13846      &    'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13847         WRITE(LO,'(1X,A,1P,3E11.3)')
13848      &    'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13849         WRITE(LO,'(1X,A,1P,3E11.3)')
13850      &    'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13851         WRITE(LO,'(1X,A)')
13852      &    'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13853         DO 27 I=1,MSOFT
13854           WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13855  27     CONTINUE
13856         WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13857      &    'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13858      &    KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13859         WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I   XPOT1/2   XMIN1/2'
13860         DO 25 I=1,MSOFT
13861           WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13862      &    XMIN(1,I),XMIN(2,I)
13863  25     CONTINUE
13864       ENDIF
13865
13866       END
13867
13868 CDECK  ID>, PHO_SELSXR
13869       SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13870      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13871 C***********************************************************************
13872 C
13873 C    select x values of soft string ends (rejection method)
13874 C
13875 C***********************************************************************
13876       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13877       SAVE
13878
13879       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13880
13881 C  input/output channels
13882       INTEGER LI,LO
13883       COMMON /POINOU/ LI,LO
13884 C  event debugging information
13885       INTEGER NMAXD
13886       PARAMETER (NMAXD=100)
13887       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13888      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13889       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13890      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13891 C  model switches and parameters
13892       CHARACTER*8 MDLNA
13893       INTEGER ISWMDL,IPAMDL
13894       DOUBLE PRECISION PARMDL
13895       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13896 C  data on most recent hard scattering
13897       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13898       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13899      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13900      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13901       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13902      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13903      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13904      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13905      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13906 C  global event kinematics and particle IDs
13907       INTEGER IFPAP,IFPAB
13908       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13909       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13910 C  obsolete cut-off information
13911       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13912       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13913
13914       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13915
13916       IF(IDEB(13).GE.10) THEN
13917         WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13918         WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13919      &    MSOFT,XS1,XS2,XMAX1,XMAX2
13920         DO 40 I=1,MSOFT
13921           WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13922  40     CONTINUE
13923       ENDIF
13924 C
13925       IREJ = 0
13926 C
13927       XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
13928       XMIN1 = MAX(AS/XMAX1,XMINK)
13929       XMIN2 = MAX(AS/XMAX2,XMINK)
13930 C
13931       IF(MSOFT.EQ.1) THEN
13932         XSOFT1(2) = 0.D0
13933         XSOFT2(2) = 0.D0
13934         RETURN
13935       ENDIF
13936       XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
13937      &        *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
13938 C
13939  10   CONTINUE
13940 C
13941       DO 50 I=2,MSOFT
13942         POT(1,I) = XPOT1(I)+1.D0
13943         POT(2,I) = XPOT2(I)+1.D0
13944         REVP(1,I) = 1.D0/POT(1,I)
13945         REVP(2,I) = 1.D0/POT(2,I)
13946         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
13947         XLMAX = XMAX1**POT(1,I)
13948         XLDIF(1,I) = XLMAX-XLMIN(1,I)
13949         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
13950         XLMAX = XMAX2**POT(2,I)
13951         XLDIF(2,I) = XLMAX-XLMIN(2,I)
13952  50   CONTINUE
13953 C
13954       ITRY0 = 0
13955  5    CONTINUE
13956       ITRY0 = ITRY0 + 1
13957       IF(ITRY0.GE.IPAMDL(181)) THEN
13958         IF(MSOFT-MSMIN.GE.2) THEN
13959           MSOFT = MSMIN
13960           GOTO 10
13961         ENDIF
13962         GOTO 1000
13963       ENDIF
13964       XREST1 = 1.D0-XS1
13965       XREST2 = 1.D0-XS2
13966       DO 100 I=2,MSOFT
13967         ITRY1 = 0
13968
13969  20     CONTINUE
13970         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
13971         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
13972         XSOFT1(I) = Z1**REVP(1,I)
13973         XSOFT2(I) = Z2**REVP(2,I)
13974         ITRY1 = ITRY1+1
13975         IF(ITRY1.GE.50) GOTO 1000
13976         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
13977
13978         XREST1 = XREST1-XSOFT1(I)
13979         IF(XREST1.LT.XMIN1) GOTO 5
13980         IF(XREST1.LT.XMIN(1,1)) GOTO 5
13981         XREST2 = XREST2-XSOFT2(I)
13982         IF(XREST2.LT.XMIN2) GOTO 5
13983         IF(XREST2.LT.XMIN(2,1)) GOTO 5
13984         IF(XREST1*XREST2.LT.AS) GOTO 5
13985
13986  100  CONTINUE
13987       XSOFT1(1) = XREST1
13988       XSOFT2(1) = XREST2
13989       IREJ=0
13990 *     XX = 1.D0
13991 *     DO 200 I=2,MSOFT
13992 *       XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
13993 *200  CONTINUE
13994       XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
13995       IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
13996
13997       XS1 = 1.D0-XREST1
13998       XS2 = 1.D0-XREST2
13999       RETURN
14000
14001  1000 CONTINUE
14002       IREJ = 1
14003       IF(IDEB(13).GE.2) THEN
14004         WRITE(LO,'(1X,A,2I4)')
14005      &    'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
14006         WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14007       ENDIF
14008
14009       END
14010
14011 CDECK  ID>, PHO_SELSX2
14012       SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14013      &                  XS1,XS2,IREJ)
14014 C***********************************************************************
14015 C
14016 C    select x values of soft string ends using PHO_RNDBET
14017 C
14018 C***********************************************************************
14019       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14020       SAVE
14021
14022       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
14023
14024 C  input/output channels
14025       INTEGER LI,LO
14026       COMMON /POINOU/ LI,LO
14027 C  event debugging information
14028       INTEGER NMAXD
14029       PARAMETER (NMAXD=100)
14030       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14031      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14032       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14033      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14034 C  model switches and parameters
14035       CHARACTER*8 MDLNA
14036       INTEGER ISWMDL,IPAMDL
14037       DOUBLE PRECISION PARMDL
14038       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14039 C  data on most recent hard scattering
14040       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14041       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14042      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14043      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14044       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14045      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14046      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14047      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14048      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14049 C  obsolete cut-off information
14050       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14051       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14052
14053       IREJ = 0
14054
14055       IF(IDEB(32).GE.10) THEN
14056         WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14057         WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14058      &    AS,XSUM1,XSUM2,XMAX1,XMAX2
14059         DO 30 I=1,2
14060           WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14061  30     CONTINUE
14062       ENDIF
14063
14064       FAC1 = 1.D0-XSUM1
14065       FAC2 = 1.D0-XSUM2
14066       FAC = FAC1*FAC2
14067       GAM1 = XPOT1(1)+1.D0
14068       GAM2 = XPOT2(1)+1.D0
14069       BET1 = XPOT1(2)+1.D0
14070       BET2 = XPOT2(2)+1.D0
14071
14072       ITRY0 = 0
14073       DO 100 I=1,IPAMDL(182)
14074
14075         ITRY1 = 0
14076  10     CONTINUE
14077           X1 = PHO_RNDBET(GAM1,BET1)
14078           ITRY1 = ITRY1+1
14079           IF(ITRY1.GE.50) GOTO 1000
14080         IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14081
14082         ITRY2 = 0
14083  11     CONTINUE
14084           X2 = PHO_RNDBET(GAM2,BET2)
14085           ITRY2 = ITRY2+1
14086           IF(ITRY2.GE.50) GOTO 1000
14087         IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14088
14089         X3 = 1.D0 - X1
14090         X4 = 1.D0 - X2
14091         IF(X1*X2*FAC.GT.AS) THEN
14092           IF(X3*X4*FAC.GT.AS) THEN
14093             XS1(1) = X1*FAC1
14094             XS1(2) = X3*FAC1
14095             XS2(1) = X2*FAC2
14096             XS2(2) = X4*FAC2
14097             IF(XS1(1).GT.XMIN(1,1)) THEN
14098               IF(XS2(1).GT.XMIN(2,1)) THEN
14099                 IF(XS1(2).GT.XMIN(1,2)) THEN
14100                   IF(XS2(2).GT.XMIN(2,2)) THEN
14101                     XSUM1 = XSUM1+XS1(2)
14102                     XSUM2 = XSUM2+XS2(2)
14103                     GOTO 300
14104                   ENDIF
14105                 ENDIF
14106               ENDIF
14107             ENDIF
14108           ENDIF
14109         ENDIF
14110         ITRY0 = ITRY0+1
14111
14112  100  CONTINUE
14113
14114  1000 CONTINUE
14115       IREJ = 1
14116       IF(IDEB(32).GE.2) THEN
14117         WRITE(LO,'(1X,A,3I4)')
14118      &    'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14119         WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14120       ENDIF
14121       RETURN
14122  300  CONTINUE
14123
14124       END
14125
14126 CDECK  ID>, PHO_SELSXS
14127       SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14128      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14129 C***********************************************************************
14130 C
14131 C    select x values of soft string ends (rescaling method)
14132 C
14133 C***********************************************************************
14134       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14135       SAVE
14136
14137       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14138
14139 C  input/output channels
14140       INTEGER LI,LO
14141       COMMON /POINOU/ LI,LO
14142 C  event debugging information
14143       INTEGER NMAXD
14144       PARAMETER (NMAXD=100)
14145       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14146      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14147       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14148      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14149 C  model switches and parameters
14150       CHARACTER*8 MDLNA
14151       INTEGER ISWMDL,IPAMDL
14152       DOUBLE PRECISION PARMDL
14153       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14154 C  data on most recent hard scattering
14155       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14156       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14157      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14158      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14159       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14160      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14161      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14162      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14163      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14164 C  obsolete cut-off information
14165       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14166       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14167
14168       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14169
14170       IREJ = 0
14171
14172  10   CONTINUE
14173
14174       IF(MSOFT.EQ.1) THEN
14175         XSOFT1(1) = 1.D0-XS1
14176         XSOFT1(2) = 0.D0
14177         XSOFT2(1) = 1.D0-XS2
14178         XSOFT2(2) = 0.D0
14179         RETURN
14180       ENDIF
14181
14182       DO 50 I=1,MSOFT
14183         POT(1,I) = XPOT1(I)+1.D0
14184         POT(2,I) = XPOT2(I)+1.D0
14185         REVP(1,I) = 1.D0/POT(1,I)
14186         REVP(2,I) = 1.D0/POT(2,I)
14187         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14188         XLMAX = XMAX1**POT(1,I)
14189         XLDIF(1,I) = XLMAX-XLMIN(1,I)
14190         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14191         XLMAX = XMAX2**POT(2,I)
14192         XLDIF(2,I) = XLMAX-XLMIN(2,I)
14193  50   CONTINUE
14194
14195       ITRY0 = 0
14196  5    CONTINUE
14197       ITRY0 = ITRY0 + 1
14198       IF(ITRY0.GE.IPAMDL(180)) THEN
14199         IF(MSOFT-MSMIN.GE.2) THEN
14200           MSOFT= MSMIN
14201           GOTO 10
14202         ENDIF
14203         GOTO 1000
14204       ENDIF
14205       XSUM1 = 0.D0
14206       XSUM2 = 0.D0
14207       DO 100 I=1,MSOFT
14208         ITRY1 = 0
14209  20     CONTINUE
14210         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14211         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14212         XSOFT1(I) = Z1**REVP(1,I)
14213         XSOFT2(I) = Z2**REVP(2,I)
14214         ITRY1 = ITRY1+1
14215         IF(ITRY1.GE.50) GOTO 1000
14216         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14217         XSUM1 = XSUM1+XSOFT1(I)
14218         XSUM2 = XSUM2+XSOFT2(I)
14219  100  CONTINUE
14220       FAC1 = (1.D0-XS1)/XSUM1
14221       FAC2 = (1.D0-XS2)/XSUM2
14222       DO 200 I=1,MSOFT
14223         XSOFT1(I) = XSOFT1(I)*FAC1
14224         XSOFT2(I) = XSOFT2(I)*FAC2
14225         IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14226         IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14227         IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14228  200  CONTINUE
14229
14230       XS1 = 1.D0-XSOFT1(1)
14231       XS2 = 1.D0-XSOFT2(1)
14232       RETURN
14233
14234  1000 CONTINUE
14235       IREJ = 1
14236       IF(IDEB(14).GE.2) THEN
14237         WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14238      &    'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14239         DO 300 I=1,MSOFT
14240           WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14241  300    CONTINUE
14242       ENDIF
14243
14244       END
14245
14246 CDECK  ID>, PHO_SELSXI
14247       SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14248      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14249 C***********************************************************************
14250 C
14251 C    select x values of soft string ends (sea independent from valence)
14252 C
14253 C***********************************************************************
14254       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14255       SAVE
14256
14257       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14258
14259 C  input/output channels
14260       INTEGER LI,LO
14261       COMMON /POINOU/ LI,LO
14262 C  event debugging information
14263       INTEGER NMAXD
14264       PARAMETER (NMAXD=100)
14265       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14266      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14267       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14268      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14269 C  model switches and parameters
14270       CHARACTER*8 MDLNA
14271       INTEGER ISWMDL,IPAMDL
14272       DOUBLE PRECISION PARMDL
14273       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14274 C  data on most recent hard scattering
14275       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14276       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14277      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14278      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14279       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14280      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14281      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14282      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14283      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14284 C  obsolete cut-off information
14285       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14286       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14287
14288       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14289
14290       IREJ = 0
14291
14292  10   CONTINUE
14293
14294       DO 50 I=1,MSOFT
14295         POT(1,I) = XPOT1(I)+1.D0
14296         POT(2,I) = XPOT2(I)+1.D0
14297         REVP(1,I) = 1.D0/POT(1,I)
14298         REVP(2,I) = 1.D0/POT(2,I)
14299         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14300         XLMAX = XMAX1**POT(1,I)
14301         XLDIF(1,I) = XLMAX-XLMIN(1,I)
14302         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14303         XLMAX = XMAX2**POT(2,I)
14304         XLDIF(2,I) = XLMAX-XLMIN(2,I)
14305  50   CONTINUE
14306
14307 C  selection of sea
14308       ITRY0 = 0
14309  5    CONTINUE
14310
14311       ITRY0 = ITRY0 + 1
14312       IF(ITRY0.GE.IPAMDL(183)) THEN
14313         IF(MSOFT-MSMIN.GE.2) THEN
14314           MSOFT = MSMIN
14315           GOTO 10
14316         ENDIF
14317         GOTO 1000
14318       ENDIF
14319       XSUM1 = XS1
14320       XSUM2 = XS2
14321       DO 100 I=3,MSOFT
14322         ITRY1 = 0
14323  20     CONTINUE
14324         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14325         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14326         XSOFT1(I) = Z1**REVP(1,I)
14327         XSOFT2(I) = Z2**REVP(2,I)
14328         ITRY1 = ITRY1+1
14329         IF(ITRY1.GE.50) GOTO 1000
14330         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14331         XSUM1 = XSUM1+XSOFT1(I)
14332         XSUM2 = XSUM2+XSOFT2(I)
14333  100  CONTINUE
14334
14335       IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14336       IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14337
14338 C  selection of valence
14339       CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14340      &  XSOFT1,XSOFT2,IREJ)
14341       IF(IREJ.NE.0) THEN
14342         IF(MSOFT-MSMIN.GE.2) THEN
14343           MSOFT = MSMIN
14344           GOTO 10
14345         ENDIF
14346         IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14347      &    'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14348      &    XSUM1,XSUM2,XMAX1,XMAX2
14349         RETURN
14350       ENDIF
14351
14352       XS1 = 1.D0-XSOFT1(1)
14353       XS2 = 1.D0-XSOFT2(1)
14354       RETURN
14355
14356  1000 CONTINUE
14357       IREJ = 1
14358       IF(IDEB(14).GE.2) THEN
14359         WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14360      &    'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14361         DO 300 I=1,MSOFT
14362           WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14363  300    CONTINUE
14364       ENDIF
14365
14366       END
14367
14368 CDECK  ID>, PHO_SELCOL
14369       SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14370 C********************************************************************
14371 C
14372 C    color combinatorics
14373 C
14374 C    input:         ICO1,2   colors of incoming particle
14375 C                   IMODE    -2  output of initialization status
14376 C                            -1  initialization
14377 C                                   ICINP(1) selection mode
14378 C                                            0   QCD
14379 C                                            1   large N_c expansion
14380 C                                   ICINP(2) max. allowed color
14381 C                            0   clear internal color counter
14382 C                            1   hadron into two colored objects
14383 C                            2   quark into quark gluon
14384 C                            3   gluon into gluon gluon
14385 C                            4   gluon into quark antiquark
14386 C
14387 C    output:        ICOA1,2  colors of first outgoing particle
14388 C                   ICOB1,2  colors of second outgoing particle
14389 C
14390 C********************************************************************
14391       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14392       SAVE
14393
14394 C  input/output channels
14395       INTEGER LI,LO
14396       COMMON /POINOU/ LI,LO
14397 C  event debugging information
14398       INTEGER NMAXD
14399       PARAMETER (NMAXD=100)
14400       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14401      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14402       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14403      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14404
14405       DATA METHOD /0/, II /0/
14406
14407       ICI1 = ICO1
14408       ICI2 = ICO2
14409       IF(METHOD.EQ.0) THEN
14410
14411         IF(IMODE.EQ.1) THEN
14412           II = II+1
14413           IF(II.GT.MAXCOL)
14414      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14415           ICOA1 = II
14416           ICOA2 = 0
14417           ICOB1 = -II
14418           ICOB2 = 0
14419         ELSE IF(IMODE.EQ.2) THEN
14420           II = II+1
14421           IF(II.GT.MAXCOL)
14422      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14423           ICOA2 = 0
14424           IF(ICI1.GT.0) THEN
14425             ICOA1 = II
14426             ICOB1 = ICI1
14427             ICOB2 = -II
14428           ELSE
14429             ICOA1 = -II
14430             ICOB1 = II
14431             ICOB2 = ICI1
14432           ENDIF
14433         ELSE IF(IMODE.EQ.3) THEN
14434           II = II+1
14435           IF(II.GT.MAXCOL)
14436      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14437           IF(DT_RNDM(DUM).GT.0.5D0) THEN
14438             ICOA1 = ICI1
14439             ICOA2 = -II
14440             ICOB1 = II
14441             ICOB2 = ICI2
14442           ELSE
14443             ICOB1 = ICI1
14444             ICOB2 = -II
14445             ICOA1 = II
14446             ICOA2 = ICI2
14447           ENDIF
14448         ELSE IF(IMODE.EQ.4) THEN
14449           ICOA1 = ICI1
14450           ICOA2 = 0
14451           ICOB1 = ICI2
14452           ICOB2 = 0
14453         ELSE IF(IMODE.EQ.0) THEN
14454           II = 0
14455         ELSE IF(IMODE.EQ.-1) THEN
14456           METHOD = ICI1
14457           MAXCOL = ICI2
14458         ELSE IF(IMODE.EQ.-2) THEN
14459           WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14460      &      METHOD,MAXCOL
14461         ELSE
14462           WRITE(LO,'(1X,A,I5)')
14463      &      'PHO_SELCOL:ERROR: unsupported mode',IMODE
14464           CALL PHO_ABORT
14465         ENDIF
14466
14467       ELSE
14468         WRITE(LO,'(1X,A,I5)')
14469      &    'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14470         CALL PHO_ABORT
14471       ENDIF
14472
14473       II = ABS(II)
14474       IF(IDEB(75).GE.10) THEN
14475         WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14476      &    IMODE,MAXCOL,II
14477         WRITE(LO,'(10X,A,2I5)') 'input  colors',ICI1,ICI2
14478         WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14479       ENDIF
14480
14481       END
14482
14483 CDECK  ID>, ipho_diqu
14484       INTEGER FUNCTION ipho_diqu(iq1,iq2)
14485 C***********************************************************************
14486 C
14487 C     selection of diquark number (PDG convention)
14488 C
14489 C***********************************************************************
14490
14491       IMPLICIT NONE
14492
14493       SAVE
14494
14495       integer iq1,iq2
14496
14497 C  input/output channels
14498       INTEGER LI,LO
14499       COMMON /POINOU/ LI,LO
14500 C  event debugging information
14501       INTEGER NMAXD
14502       PARAMETER (NMAXD=100)
14503       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14504      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14505       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14506      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14507 C  model switches and parameters
14508       CHARACTER*8 MDLNA
14509       INTEGER ISWMDL,IPAMDL
14510       DOUBLE PRECISION PARMDL
14511       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14512
14513 C  external functions
14514       double precision DT_RNDM
14515
14516 C  local variables
14517       integer i0,i1,i2
14518       double precision dum
14519
14520       i1 = abs(iq1)
14521       i2 = abs(iq2)
14522
14523       if(i1.eq.i2) then
14524         i0 = i1*1100+3
14525       else
14526         i0 = max(i1,i2)*1000+min(i1,i2)*100
14527         if(DT_RNDM(dum).gt.PARMDL(135)) then
14528           i0 = i0+1
14529         else
14530           i0 = i0+3
14531         endif
14532       endif
14533
14534       ipho_diqu = sign(i0,iq1)
14535
14536       END
14537
14538 CDECK  ID>, PHO_PARREM
14539       SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14540 C**********************************************************************
14541 C
14542 C     selection of particle remnant flavour(s) (quark or diquark)
14543 C
14544 C     input:    INDX   index of particle in /POEVT1/
14545 C               IOUT   parton which was taken out
14546 C
14547 C     output:   IREM   remnant according to valence flavours
14548 C               IREJ   0  flavour combination possible
14549 C                      1  flavour combination impossible
14550 C
14551 C     all particle ID are given according to PDG conventions
14552 C
14553 C**********************************************************************
14554
14555       IMPLICIT NONE
14556
14557       SAVE
14558
14559       integer INDX,IOUT,IREM,IREJ
14560
14561 C  input/output channels
14562       INTEGER LI,LO
14563       COMMON /POINOU/ LI,LO
14564 C  event debugging information
14565       INTEGER NMAXD
14566       PARAMETER (NMAXD=100)
14567       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14568      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14569       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14570      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14571
14572 C  standard particle data interface
14573       INTEGER NMXHEP
14574
14575       PARAMETER (NMXHEP=4000)
14576
14577       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14578       DOUBLE PRECISION PHEP,VHEP
14579       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14580      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14581      &                VHEP(4,NMXHEP)
14582 C  extension to standard particle data interface (PHOJET specific)
14583       INTEGER IMPART,IPHIST,ICOLOR
14584       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14585
14586 C  general particle data
14587       double precision xm_list,tau_list,gam_list,
14588      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14589      &  xm_bb82_list,xm_bb102_list
14590       integer          ich3_list,iba3_list,iq_list,
14591      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
14592       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14593      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
14594      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14595      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14596      &  ich3_list(300),iba3_list(300),iq_list(3,300),
14597      &  id_psm_list(6,6),id_vem_list(6,6),
14598      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
14599
14600 C  external functions
14601       integer ipho_diqu
14602
14603 C  local variables
14604       integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14605       dimension IQUA(3),IDQ(2)
14606
14607       ID1 = IDHEP(INDX)
14608       ID2 = IMPART(INDX)
14609       IREJ = 0
14610
14611       IF(ID2.EQ.0) THEN
14612         WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14613         CALL PHO_ABORT
14614       ENDIF
14615
14616 C  particle with flavour mixing
14617       if(ID1.eq.22) then
14618 C  photon
14619         IREM = -IOUT
14620         GOTO 100
14621       else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14622 C  pi0, rho0, and omega
14623         IF(ABS(IOUT).LE.2) THEN
14624           IREM = -IOUT
14625           GOTO 100
14626         ELSE
14627           GOTO 150
14628         ENDIF
14629       else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14630 C  neutral kaons (K0,K0-bar)
14631         if(abs(IOUT).eq.1) then
14632           IREM = sign(3,-IOUT)
14633           goto 100
14634         else if(abs(IOUT).eq.3) then
14635           IREM = sign(1,-IOUT)
14636           goto 100
14637         else
14638           goto 150
14639         endif
14640       else if((ID1.eq.990).or.(ID1.eq.110)) then
14641 C  pomeron and reggeon
14642         IREM = -IOUT
14643         GOTO 100
14644       endif
14645
14646 C  ordinary hadron
14647       ID = abs(ID2)
14648       IS = sign(1,ID2)
14649       IQUA(1) = iq_list(1,ID)*IS
14650       IQUA(2) = iq_list(2,ID)*IS
14651       IQUA(3) = iq_list(3,ID)*IS
14652
14653 C  compare to flavour content
14654       IF(ABS(IOUT).LT.1000) THEN
14655 C  single quark requested
14656         IF(IQUA(1).EQ.IOUT) THEN
14657           K1 = 2
14658           K2 = 3
14659         ELSE IF(IQUA(2).EQ.IOUT) THEN
14660           K1 = 1
14661           K2 = 3
14662         ELSE IF(IQUA(3).EQ.IOUT) THEN
14663           K1 = 1
14664           K2 = 2
14665         ELSE
14666           GOTO 150
14667         ENDIF
14668         IF(IQUA(3).EQ.0) THEN
14669           IREM = IQUA(K1)
14670         ELSE
14671           IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14672         ENDIF
14673       ELSE IF(IQUA(3).NE.0) THEN
14674 C  diquark requested from baryon
14675         IDQ(1) = IOUT/1000
14676         IDQ(2) = (IOUT-IDQ(1)*1000)/100
14677         do i=1,2
14678           do k=1,3
14679             if(IDQ(i).eq.IQUA(k)) then
14680               IQUA(k) = 0
14681               goto 110
14682             endif
14683           enddo
14684           goto 150
14685  110      continue
14686         enddo
14687         IREM = IQUA(1)+IQUA(2)+IQUA(3)
14688       ENDIF
14689
14690  100  CONTINUE
14691 C  debug output
14692       IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14693      &  'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14694      &  INDX,ID1,ID2,IOUT,IREM
14695       RETURN
14696
14697 C  rejection
14698  150  CONTINUE
14699       IREJ = 1
14700       IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14701      &  'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14702
14703       END
14704
14705 CDECK  ID>, PHO_VALFLA
14706       SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14707 C***********************************************************************
14708 C
14709 C     selection of valence flavour decomposition of particle IPAR
14710 C
14711 C     input:    IPAR   particle index in /POEVT1/
14712 C                      -1   initialization
14713 C                      -2   output of statistics
14714 C               XMASS  mass of particle
14715 C                      (important for pomeron:
14716 C                       mass dependent flavour sampling)
14717 C
14718 C     output:   IFL1,IFL2
14719 C               baryon: IFL1  diquark flavour
14720 C               (valence flavours according to PDG conventions)
14721 C
14722 C***********************************************************************
14723       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14724       SAVE
14725
14726       PARAMETER ( EPS    =  0.1D0,
14727      &            DEPS   =  1.D-15)
14728
14729 C  input/output channels
14730       INTEGER LI,LO
14731       COMMON /POINOU/ LI,LO
14732 C  event debugging information
14733       INTEGER NMAXD
14734       PARAMETER (NMAXD=100)
14735       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14736      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14737       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14738      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14739 C  model switches and parameters
14740       CHARACTER*8 MDLNA
14741       INTEGER ISWMDL,IPAMDL
14742       DOUBLE PRECISION PARMDL
14743       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14744
14745 C  standard particle data interface
14746       INTEGER NMXHEP
14747
14748       PARAMETER (NMXHEP=4000)
14749
14750       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14751       DOUBLE PRECISION PHEP,VHEP
14752       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14753      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14754      &                VHEP(4,NMXHEP)
14755 C  extension to standard particle data interface (PHOJET specific)
14756       INTEGER IMPART,IPHIST,ICOLOR
14757       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14758
14759 C  general particle data
14760       double precision xm_list,tau_list,gam_list,
14761      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14762      &  xm_bb82_list,xm_bb102_list
14763       integer          ich3_list,iba3_list,iq_list,
14764      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
14765       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14766      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
14767      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14768      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14769      &  ich3_list(300),iba3_list(300),iq_list(3,300),
14770      &  id_psm_list(6,6),id_vem_list(6,6),
14771      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
14772
14773       data ITMX / 5 /
14774
14775       IF(IPAR.GT.0) THEN
14776         K = IPAR
14777 C  select particle code
14778         ID1 = IDHEP(K)
14779         ID  = abs(IMPART(K))
14780         IBAR = IPHO_BAR3(K,2)
14781         ITER = 0
14782
14783  10     CONTINUE
14784
14785         ifl1 = 0
14786         ifl2 = 0
14787         ITER = ITER+1
14788         if(ITER.GT.ITMX) then
14789           WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14790      &      'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14791           return
14792         endif
14793
14794 C  not baryon
14795         IF(IBAR.EQ.0) THEN
14796
14797 C  photon
14798           IF(ID1.EQ.22) THEN
14799 C  charge dependent flavour sampling
14800  15         CONTINUE
14801             K = INT(DT_RNDM(E1)*6.D0)+1
14802             IF(K.LE.4) THEN
14803               IFL1 = 2
14804               IFL2 = -2
14805             ELSE IF(K.EQ.5) THEN
14806               IFL1 = 1
14807               IFL2 = -1
14808             ELSE
14809               IFL1 = 3
14810               IFL2 = -3
14811             ENDIF
14812 C  optional strangeness suppression
14813             IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14814             IF(DT_RNDM(DUM).LT.0.5D0) THEN
14815               K = IFL1
14816               IFL1 = IFL2
14817               IFL2 = K
14818             ENDIF
14819
14820 C  pomeron, reggeon
14821           ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14822             IF(ISWMDL(19).EQ.0) THEN
14823 C  SU(3) symmetric valences
14824               K = INT(DT_RNDM(E1)*3.D0)+1
14825               IF(DT_RNDM(DUM).LT.0.5D0) THEN
14826                 IFL1 = K
14827               ELSE
14828                 IFL1 = -K
14829               ENDIF
14830               IFL2 = -IFL1
14831             ELSE IF(ISWMDL(19).EQ.1) THEN
14832 C  mass dependent flavour sampling
14833               EMIN = MIN(E1,E2)
14834               CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14835             ELSE
14836               WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14837      &          'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14838               CALL PHO_ABORT
14839             ENDIF
14840
14841 C  meson with flavour mixing
14842           ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14843             K = INT(2.D0*DT_RNDM(E1))+1
14844             IFL1 = K
14845             IFL2 = -K
14846 C  meson (standard)
14847           ELSE
14848             K = INT(2.D0*DT_RNDM(E1))+1
14849             IFL1 = iq_list(K,ID)
14850             K = MOD(K,2) + 1
14851             IFL2 = iq_list(K,ID)
14852             if(IFL1.EQ.0) then
14853               EMIN = MIN(E1,E2)
14854               CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14855             endif
14856           ENDIF
14857
14858 C  baryon
14859         ELSE
14860           K = INT(2.999999D0*DT_RNDM(E2))+1
14861           K1 = MOD(K,3)+1
14862           K2 = MOD(K1,3)+1
14863           IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14864           IFL2 = iq_list(K,ID)
14865         ENDIF
14866
14867 C  change sign for antiparticles
14868         if(ID1.lt.0) then
14869           IFL1 = -IFL1
14870           IFL2 = -IFL2
14871         endif
14872
14873 ************************************************************************
14874 C  check kinematic constraints
14875 *       IF((PHO_PMASS(IFL1,3).GT.E1)
14876 *    &     .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14877 ************************************************************************
14878
14879 C  debug output
14880         IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14881      &    'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14882
14883       ELSE IF(IPAR.EQ.-1) THEN
14884 C  initialization
14885
14886       ELSE IF(IPAR.EQ.-2) THEN
14887 C  output of final statistics
14888
14889       ELSE
14890         WRITE(LO,'(1X,A,I10)')
14891      &    'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14892         CALL PHO_ABORT
14893       ENDIF
14894
14895       END
14896
14897 CDECK  ID>, PHO_REGFLA
14898       SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14899 C**********************************************************************
14900 C
14901 C     selection of reggeon flavours
14902 C
14903 C     input:    JM1,JM2      position index of mother hadrons
14904 C
14905 C     output:   IFLR1,IFLR2  valence flavours according to
14906 C                            PDG conventions and JM1,JM2
14907 C               IREJ         0  reggeon possible
14908 C                            1  reggeon impossible
14909 C
14910 C**********************************************************************
14911       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14912       SAVE
14913
14914       PARAMETER ( EPS    =  0.1D0,
14915      &            DEPS   =  1.D-15)
14916
14917 C  input/output channels
14918       INTEGER LI,LO
14919       COMMON /POINOU/ LI,LO
14920 C  event debugging information
14921       INTEGER NMAXD
14922       PARAMETER (NMAXD=100)
14923       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14924      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14925       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14926      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14927 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
14928       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
14929       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
14930       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
14931      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
14932
14933 C  standard particle data interface
14934       INTEGER NMXHEP
14935
14936       PARAMETER (NMXHEP=4000)
14937
14938       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14939       DOUBLE PRECISION PHEP,VHEP
14940       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14941      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14942      &                VHEP(4,NMXHEP)
14943 C  extension to standard particle data interface (PHOJET specific)
14944       INTEGER IMPART,IPHIST,ICOLOR
14945       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14946
14947       IF(JM1.GT.0) THEN
14948         IREJ = 0
14949         ITER = 0
14950 C  available energy
14951         E1   = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
14952      &             -(PHEP(1,JM1)+PHEP(1,JM2))**2
14953      &             -(PHEP(2,JM1)+PHEP(2,JM2))**2
14954      &             -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
14955  50     CONTINUE
14956         ITER = ITER+1
14957         IF(ITER.GT.50) THEN
14958           IREJ = 1
14959 C  debug output
14960           IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
14961      &      'PHO_REGFLA: rejection, no reggeon found for',
14962      &      IDHEP(JM1),IDHEP(JM2),E1
14963           RETURN
14964         ENDIF
14965
14966         CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
14967         CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
14968         IF(IFLA1.EQ.-IFLB1) THEN
14969           IFLR1 = IFLA2
14970           IFLR2 = IFLB2
14971         ELSE IF(IFLA1.EQ.-IFLB2) THEN
14972           IFLR1 = IFLA2
14973           IFLR2 = IFLB1
14974         ELSE IF(IFLA2.EQ.-IFLB1) THEN
14975           IFLR1 = IFLA1
14976           IFLR2 = IFLB2
14977         ELSE IF(IFLA2.EQ.-IFLB2) THEN
14978           IFLR1 = IFLA1
14979           IFLR2 = IFLB1
14980         ELSE
14981 C  debug output
14982           IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
14983      &      'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
14984           GOTO 50
14985         ENDIF
14986 C  debug output
14987         IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
14988      &    'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
14989      &    JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
14990       ELSE IF(JM1.EQ.-1) THEN
14991 C  initialization
14992       ELSE IF(JM1.EQ.-2) THEN
14993 C  output of statistics
14994       ELSE
14995         WRITE(LO,'(1X,A,I10)')
14996      &    'PHO_REGFLA: invalid mother particle (JM1)',JM1
14997         CALL PHO_ABORT
14998       ENDIF
14999
15000       END
15001
15002 CDECK  ID>, PHO_SEAFLA
15003       SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
15004 C**********************************************************************
15005 C
15006 C     selection of sea flavour content of particle IPAR
15007 C
15008 C     input:    IPAR    particle index in /POEVT1/
15009 C               CHMASS  available invariant string mass
15010 C                       positive mass --> use BAMJET method
15011 C                       negative mass --> SU(3) symmetric sea according
15012 C                       to values given in PARMDL(1-6)
15013 C               IPAR    -1 initialization
15014 C                       -2 output of statistics
15015 C
15016 C     output:   sea flavours according to PDG conventions
15017 C
15018 C**********************************************************************
15019       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15020       SAVE
15021
15022       PARAMETER ( EPS    =  0.1D0,
15023      &            DEPS   =  1.D-15)
15024
15025 C  input/output channels
15026       INTEGER LI,LO
15027       COMMON /POINOU/ LI,LO
15028 C  event debugging information
15029       INTEGER NMAXD
15030       PARAMETER (NMAXD=100)
15031       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15032      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15033       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15034      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15035 C  model switches and parameters
15036       CHARACTER*8 MDLNA
15037       INTEGER ISWMDL,IPAMDL
15038       DOUBLE PRECISION PARMDL
15039       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15040 C  some hadron information, will be deleted in future versions
15041       INTEGER NFS
15042       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15043       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15044
15045       IF(IPAR.GT.0) THEN
15046         IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15047 C  constant weights for sea
15048  15       CONTINUE
15049             SUM = 0.D0
15050             DO 40 K=1,NFSEA
15051               SUM = SUM + PARMDL(K)
15052  40         CONTINUE
15053             XI = DT_RNDM(SUM)*SUM
15054             SUM = 0.D0
15055             DO 50 K=1,NFSEA
15056               SUM = SUM + PARMDL(K)
15057               IF(XI.LE.SUM) GOTO 55
15058  50         CONTINUE
15059  55         CONTINUE
15060           IF(K.GT.NFSEA) GOTO 15
15061         ELSE
15062 C  mass dependent flavour sampling
15063  10       CONTINUE
15064             CALL PHO_FLAUX(CHMASS,K)
15065           IF(K.GT.NFSEA) GOTO 10
15066         ENDIF
15067         IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15068         IFL1 = K
15069         IFL2 = -K
15070         IF(IDEB(46).GE.10) THEN
15071           WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15072      &      IPAR,IFL1,IFL2,CHMASS
15073         ENDIF
15074       ELSE IF(IPAR.EQ.-1) THEN
15075 C  initialization
15076         NFSEA = NFS
15077       ELSE IF(IPAR.EQ.-2) THEN
15078 C  output of statistics
15079       ELSE
15080         WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15081         CALL PHO_ABORT
15082       ENDIF
15083
15084       END
15085
15086 CDECK  ID>, PHO_FLAUX
15087       SUBROUTINE PHO_FLAUX(EQUARK,K)
15088 C***********************************************************************
15089 C
15090 C    auxiliary subroutine to select flavours
15091 C
15092 C********************************************************************
15093       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15094       SAVE
15095
15096       PARAMETER ( DEPS   =  1.D-14 )
15097
15098 C  input/output channels
15099       INTEGER LI,LO
15100       COMMON /POINOU/ LI,LO
15101 C  event debugging information
15102       INTEGER NMAXD
15103       PARAMETER (NMAXD=100)
15104       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15105      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15106       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15107      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15108 C  some hadron information, will be deleted in future versions
15109       INTEGER NFS
15110       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15111       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15112
15113       DIMENSION WGHT(9)
15114
15115 C  calculate weights for given energy
15116       IF(EQUARK.LT.QMASS(1)) THEN
15117         IF(IDEB(16).GE.5)
15118      &    WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15119      &      EQUARK
15120         WGHT(1) = 0.5D0
15121         WGHT(2) = 0.5D0
15122         WGHT(3) = 0.D0
15123         WGHT(4) = 0.D0
15124         SUM = 1.D0
15125       ELSE
15126         SUM = 0.D0
15127         DO 305 K=1,NFS
15128           IF(EQUARK.GT.QMASS(K)) THEN
15129             WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15130           ELSE
15131             WGHT(K) = 0.D0
15132           ENDIF
15133           SUM = SUM + WGHT(K)
15134  305    CONTINUE
15135       ENDIF
15136 C  sample flavours
15137       XI = SUM*(DT_RNDM(SUM)-DEPS)
15138       K = 0
15139       SUM = 0.D0
15140  400  CONTINUE
15141         K = K+1
15142         SUM = SUM + WGHT(K)
15143       IF(XI.GT.SUM) GOTO 400
15144 C  debug output
15145       IF(IDEB(16).GE.20) THEN
15146         WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15147       ENDIF
15148       END
15149
15150 CDECK  ID>, PHO_BETAF
15151       DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15152 C********************************************************************
15153 C
15154 C     weights of different quark flavours
15155 C
15156 C********************************************************************
15157       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15158       SAVE
15159
15160       AX=0.D0
15161       BETX1=BET*X1
15162       IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15163       AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15164
15165       PHO_BETAF=AX+AY
15166
15167       END
15168
15169 CDECK  ID>, PHO_MCHECK
15170       SUBROUTINE PHO_MCHECK(J1,IREJ)
15171 C********************************************************************
15172 C
15173 C    check parton momenta for fragmentation
15174 C
15175 C    input:      J1      first  string number
15176 C                        /POEVT1/
15177 C                        /POSTRG/
15178 C
15179 C    output:             /POEVT1/
15180 C                        /POSTRG/
15181 C                IREJ    0  successful
15182 C                        1  failure
15183 C
15184 C    in case of very small string mass:
15185 C                NNCH    mass label of string
15186 C                        0  string
15187 C                       -1  octett baryon / pseudo scalar meson
15188 C                        1  decuplett baryon / vector meson
15189 C                IBHAD   hadron number according to CPC,
15190 C                        string will be treated as resonance
15191 C                        (sometimes far off mass shell)
15192 C
15193 C    constant WIDTH ( 0.01GeV ) determines range of acceptance
15194 C
15195 C********************************************************************
15196       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15197       SAVE
15198
15199       PARAMETER ( WIDTH  =  0.01D0,
15200      &            DEPS   =  1.D-15 )
15201
15202 C  input/output channels
15203       INTEGER LI,LO
15204       COMMON /POINOU/ LI,LO
15205 C  event debugging information
15206       INTEGER NMAXD
15207       PARAMETER (NMAXD=100)
15208       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15209      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15210       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15211      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15212 C  model switches and parameters
15213       CHARACTER*8 MDLNA
15214       INTEGER ISWMDL,IPAMDL
15215       DOUBLE PRECISION PARMDL
15216       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15217
15218 C  standard particle data interface
15219       INTEGER NMXHEP
15220
15221       PARAMETER (NMXHEP=4000)
15222
15223       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15224       DOUBLE PRECISION PHEP,VHEP
15225       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15226      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15227      &                VHEP(4,NMXHEP)
15228 C  extension to standard particle data interface (PHOJET specific)
15229       INTEGER IMPART,IPHIST,ICOLOR
15230       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15231
15232 C  color string configurations including collapsed strings and hadrons
15233       INTEGER MSTR
15234       PARAMETER (MSTR=500)
15235       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15236       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15237      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15238      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15239 C  internal rejection counters
15240       INTEGER NMXJ
15241       PARAMETER (NMXJ=60)
15242       CHARACTER*10 REJTIT
15243       INTEGER IFAIL
15244       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15245
15246       IREJ = 0
15247 C  quark antiquark jet
15248       STRM = PHEP(5,NPOS(1,J1))
15249       IF(NCODE(J1).EQ.3) THEN
15250         CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15251      &    AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15252         IF(IDEB(18).GE.5)
15253      &    WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15254      &      'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15255      &      J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15256         IF(STRM.LT.AMPS) THEN
15257           IREJ = 1
15258           IFAIL(20) = IFAIL(20) + 1
15259           RETURN
15260         ELSE IF(STRM.LT.AMPS2) THEN
15261           IF(STRM.LT.(AMVE-WIDTH)) THEN
15262             NNCH(J1) = -1
15263             IBHAD(J1) = IPS
15264           ELSE
15265             NNCH(J1) = 1
15266             IBHAD(J1) = IVE
15267           ENDIF
15268         ELSE
15269           NNCH(J1) = 0
15270           IBHAD(J1) = 0
15271         ENDIF
15272 C  quark diquark or v.s. jet
15273       ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15274         CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15275      &              AM8,AM82,AM10,AM102,I8,I10)
15276         IF(IDEB(18).GE.5)
15277      &    WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15278      &            'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15279      &            J1,STRM,AM8,AM82,AM10,AM102
15280         IF(STRM.LT.AM8) THEN
15281           IREJ = 1
15282           IFAIL(19) = IFAIL(19) + 1
15283           RETURN
15284         ELSE IF(STRM.LT.AM82) THEN
15285           IF(STRM.LT.(AM10-WIDTH)) THEN
15286             NNCH(J1) = -1
15287             IBHAD(J1) = I8
15288           ELSE
15289             NNCH(J1) = 1
15290             IBHAD(J1) = I10
15291           ENDIF
15292         ELSE
15293           NNCH(J1) = 0
15294           IBHAD(J1) = 0
15295         ENDIF
15296 C  diquark a-diquark string
15297       ELSE IF(NCODE(J1).EQ.5) THEN
15298         CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15299      &              AM82,AM102)
15300         IF(IDEB(18).GE.5)
15301      &    WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15302      &            'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15303      &            J1,STRM,AM82,AM102
15304         IF(STRM.LT.AM82) THEN
15305           IREJ = 1
15306           IFAIL(19) = IFAIL(19) + 1
15307           RETURN
15308         ELSE
15309           NNCH(J1) = 0
15310           IBHAD(J1) = 0
15311         ENDIF
15312       ELSE IF(NCODE(J1).LT.0) THEN
15313         RETURN
15314       ELSE
15315         WRITE(LO,'(/,1X,2A,2I8)')  'PHO_MCHECK: ',
15316      &    'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15317         CALL PHO_ABORT
15318       ENDIF
15319       END
15320
15321 CDECK  ID>, PHO_POMCOR
15322       SUBROUTINE PHO_POMCOR(IREJ)
15323 C********************************************************************
15324 C
15325 C    join quarks to gluons in case of too small masses
15326 C
15327 C    input:              /POEVT1/
15328 C                        /POSTRG/
15329 C                IREJ    -1          initialization
15330 C                        -2          output of statistics
15331 C
15332 C    output:             /POEVT1/
15333 C                        /POSTRG/
15334 C                IREJ    0  successful
15335 C                        1  failure
15336 C
15337 C
15338 C********************************************************************
15339       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15340       SAVE
15341
15342       PARAMETER ( EPS    =  1.D-10 )
15343
15344 C  input/output channels
15345       INTEGER LI,LO
15346       COMMON /POINOU/ LI,LO
15347 C  event debugging information
15348       INTEGER NMAXD
15349       PARAMETER (NMAXD=100)
15350       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15351      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15352       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15353      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15354 C  model switches and parameters
15355       CHARACTER*8 MDLNA
15356       INTEGER ISWMDL,IPAMDL
15357       DOUBLE PRECISION PARMDL
15358       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15359
15360 C  standard particle data interface
15361       INTEGER NMXHEP
15362
15363       PARAMETER (NMXHEP=4000)
15364
15365       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15366       DOUBLE PRECISION PHEP,VHEP
15367       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15368      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15369      &                VHEP(4,NMXHEP)
15370 C  extension to standard particle data interface (PHOJET specific)
15371       INTEGER IMPART,IPHIST,ICOLOR
15372       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15373
15374 C  color string configurations including collapsed strings and hadrons
15375       INTEGER MSTR
15376       PARAMETER (MSTR=500)
15377       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15378       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15379      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15380      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15381
15382       DIMENSION PJ(4)
15383
15384       IF(IREJ.EQ.-1) THEN
15385         ICTOT = 0
15386         ICCOR = 0
15387         RETURN
15388       ELSE IF(IREJ.EQ.-2) THEN
15389 C *** Commented by Chiara
15390 C        WRITE(LO,'(/1X,A,2I8)')
15391 C     &    'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15392         RETURN
15393       ENDIF
15394 C
15395       IREJ = 0
15396 C
15397       NITER = 100
15398       ITER = 0
15399       ICTOT = ICTOT+ISTR
15400       IF(ISWMDL(25).LE.0) RETURN
15401 C  debug string entries
15402       IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15403 C
15404  50   CONTINUE
15405       ITER = ITER+1
15406       IF(ITER.GE.NITER) THEN
15407         IREJ = 1
15408         IF(IDEB(83).GE.2) THEN
15409           WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15410           IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15411         ENDIF
15412         RETURN
15413       ENDIF
15414 C
15415 C  check mass limits
15416       ISTRO = ISTR
15417       DO 100 I=1,ISTRO
15418         IF(NCODE(I).LT.0) GOTO 99
15419         J1 = NPOS(1,I)
15420         NRPOM = IPHIST(2,J1)
15421         IF(NRPOM.GE.100) GOTO 99
15422         CMASS0 = PHEP(5,J1)
15423 C  get masses
15424         IF(NCODE(I).EQ.3) THEN
15425           CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15426         ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15427           CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15428      &                AM1,AM2,AM3,AM4,IP1,IP2)
15429         ELSE IF(NCODE(I).EQ.5) THEN
15430           CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15431      &                AM1,AM2)
15432           AM3 = 0.D0
15433           AM4 = 0.D0
15434           IP1 = 0
15435           IP2 = 0
15436         ELSE IF(NCODE(I).EQ.7) THEN
15437           GOTO 99
15438         ELSE IF(NCODE(I).LT.0) THEN
15439           GOTO 99
15440         ELSE
15441           WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15442      &                            J1,NCODE(I)
15443           CALL PHO_ABORT
15444         ENDIF
15445         IF(IDEB(83).GE.5)
15446      &    WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15447      &      'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15448      &      I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15449 C  select masses to correct
15450         IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15451           DO 200 K=1,ISTRO
15452             IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15453               J2 = NPOS(1,K)
15454 C  join quarks to gluon
15455               IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15456 C  flavour check
15457                 IFL1 = 0
15458                 IFL2 = 0
15459                 PROB1 = 0.D0
15460                 PROB2 = 0.D0
15461                 KK1 = NPOS(2,I)
15462                 KK2 = NPOS(2,K)
15463                 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15464                   CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15465      &                   -(PHEP(1,KK1)+PHEP(1,KK2))**2
15466      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15467      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15468                   IFL1 = ABS(IDHEP(KK1))
15469                   IF(IFL1.GT.2) THEN
15470                     PROB1 = 0.1D0/MAX(CMASS,EPS)
15471                   ELSE
15472                     PROB1 = 0.9D0/MAX(CMASS,EPS)
15473                   ENDIF
15474                 ENDIF
15475                 KK1 = ABS(NPOS(3,I))
15476                 KK2 = ABS(NPOS(3,K))
15477                 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15478                   CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15479      &                   -(PHEP(1,KK1)+PHEP(1,KK2))**2
15480      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15481      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15482                   IFL2 = ABS(IDHEP(KK1))
15483                   IF(IFL2.GT.2) THEN
15484                     PROB2 = 0.1D0/MAX(CMASS,EPS)
15485                   ELSE
15486                     PROB2 = 0.9D0/MAX(CMASS,EPS)
15487                   ENDIF
15488                 ENDIF
15489                 IF(IFL1+IFL2.EQ.0) GOTO 99
15490 C  fusion possible
15491                 ICCOR = ICCOR+1
15492                 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15493                   JJ = 2
15494                   JE = 3
15495                 ELSE
15496                   JJ = 3
15497                   JE = 2
15498                 ENDIF
15499                 KK1 = ABS(NPOS(JJ,I))
15500                 KK2 = ABS(NPOS(JJ,K))
15501                 I1 = ABS(NPOS(JE,I))
15502                 I2 = KK1
15503                 IS = SIGN(1,I2-I1)
15504                 I2 = I2 - IS
15505                 K1 = KK2
15506                 K2 = ABS(NPOS(JE,K))
15507                 KS = SIGN(1,K2-K1)
15508                 K1 = K1 + KS
15509                 IP1 = NHEP+1
15510 C  copy mother partons of string I
15511                 DO 300 II=I1,I2,IS
15512                   CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15513      &              PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15514      &              ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15515  300            CONTINUE
15516 C  register gluon
15517                 DO 350 II=1,4
15518                   PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15519  350            CONTINUE
15520                 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15521      &            I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15522 C  copy mother partons of string K
15523                 DO 400 II=K1,K2,KS
15524                   CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15525      &              PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15526      &              ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15527  400            CONTINUE
15528 C  create new string entry
15529                 DO 450 II=1,4
15530                   PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15531  450            CONTINUE
15532                 IP2 = IPOS
15533                 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15534      &            PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15535      &            ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15536 C  delete string K in /POSTRG/
15537                 NCODE(K) = -999
15538 C  update string I in /POSTRG/
15539                 NPOS(1,I) = IPOS
15540                 NPOS(2,I) = IP1
15541                 NPOS(3,I) = -IP2
15542 C  calculate new CPC string codes
15543                 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15544      &            IPAR2(I),IPAR3(I),IPAR4(I))
15545                 GOTO 99
15546               ENDIF
15547             ENDIF
15548  200      CONTINUE
15549         ENDIF
15550  99     CONTINUE
15551  100  CONTINUE
15552       IF(IDEB(83).GE.20) THEN
15553         WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15554         IF(IDEB(83).GE.22) THEN
15555           CALL PHO_PRSTRG
15556           CALL PHO_PREVNT(0)
15557         ENDIF
15558       ENDIF
15559
15560       END
15561
15562 CDECK  ID>, PHO_MASCOR
15563       SUBROUTINE PHO_MASCOR(IREJ)
15564 C********************************************************************
15565 C
15566 C    check and adjust parton momenta for fragmentation
15567 C
15568 C    input:      /POEVT1/
15569 C                /POSTRG/
15570 C                IREJ    -1          initialization
15571 C                        -2          output of statistics
15572 C
15573 C    output:     /POEVT1/
15574 C                /POSTRG/
15575 C                IREJ    0  successful
15576 C                        1  failure
15577 C
15578 C    in case of very small string mass:
15579 C       - direct manipulation of /POEVT1/ and /POEVT2/
15580 C       - string will be deleted from /POSTRG/ (label -99)
15581 C
15582 C********************************************************************
15583       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15584       SAVE
15585
15586       PARAMETER ( EPS    =  1.D-10,
15587      &            EMIN   =  0.3D0,
15588      &            DEPS   =  1.D-15)
15589
15590 C  input/output channels
15591       INTEGER LI,LO
15592       COMMON /POINOU/ LI,LO
15593 C  event debugging information
15594       INTEGER NMAXD
15595       PARAMETER (NMAXD=100)
15596       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15597      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15598       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15599      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15600 C  internal rejection counters
15601       INTEGER NMXJ
15602       PARAMETER (NMXJ=60)
15603       CHARACTER*10 REJTIT
15604       INTEGER IFAIL
15605       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15606 C  model switches and parameters
15607       CHARACTER*8 MDLNA
15608       INTEGER ISWMDL,IPAMDL
15609       DOUBLE PRECISION PARMDL
15610       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15611
15612 C  standard particle data interface
15613       INTEGER NMXHEP
15614
15615       PARAMETER (NMXHEP=4000)
15616
15617       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15618       DOUBLE PRECISION PHEP,VHEP
15619       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15620      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15621      &                VHEP(4,NMXHEP)
15622 C  extension to standard particle data interface (PHOJET specific)
15623       INTEGER IMPART,IPHIST,ICOLOR
15624       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15625
15626 C  color string configurations including collapsed strings and hadrons
15627       INTEGER MSTR
15628       PARAMETER (MSTR=500)
15629       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15630       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15631      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15632      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15633
15634       DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15635
15636       IF(IREJ.EQ.-1) THEN
15637         ICTOT = 0
15638         ICCOR = 0
15639         RETURN
15640       ELSE IF(IREJ.EQ.-2) THEN
15641 C *** Commented by Chiara
15642 C        WRITE(LO,'(/1X,A,2I8/)')
15643 C     &    'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15644         RETURN
15645       ENDIF
15646
15647       IREJ = 0
15648       NITER = 100
15649       ITER = 0
15650       ICTOT = ICTOT+ISTR
15651       IF(ISWMDL(7).EQ.-1) RETURN
15652 C  debug /POSTRG/
15653       IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15654
15655       ITOUCH = 0
15656  50   CONTINUE
15657       ITER = ITER+1
15658       IF(ITER.GE.NITER) THEN
15659         IREJ = 1
15660         IF(IDEB(42).GE.2) THEN
15661           WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15662           IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15663         ENDIF
15664         RETURN
15665       ENDIF
15666
15667 C  check mass limits
15668       IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15669         IM1 = 1
15670         IM2 = ISTR
15671         IST = 1
15672       ELSE
15673         IM1 = ISTR
15674         IM2 = 1
15675         IST = -1
15676       ENDIF
15677       DO 100 I=IM1,IM2,IST
15678         J1 = NPOS(1,I)
15679         CMASS0 = PHEP(5,J1)
15680 C  get masses
15681         IF(NCODE(I).EQ.3) THEN
15682           CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15683         ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15684           CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15685      &                AM1,AM2,AM3,AM4,IP1,IP2)
15686         ELSE IF(NCODE(I).EQ.5) THEN
15687           CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15688      &              AM1,AM2)
15689           AM3 = 0.D0
15690           AM4 = 0.D0
15691           IP1 = 0
15692           IP2 = 0
15693         ELSE IF(NCODE(I).EQ.7) THEN
15694           AM1 = 0.15D0
15695           AM2 = 0.3D0
15696           AM3 = 0.765D0
15697           AM4 = 1.5D0
15698 *??????????????????????????????????
15699           IP1 = 23
15700           IP2 = 33
15701 *??????????????????????????????????
15702         ELSE IF(NCODE(I).LT.0) THEN
15703           GOTO 90
15704         ELSE
15705           WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15706      &                            J1,NCODE(I)
15707           CALL PHO_ABORT
15708         ENDIF
15709         IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15710      &    'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15711      &    I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15712 C  select masses to correct
15713         IBHAD(I) = 0
15714         NNCH(I) = 0
15715 C  correction needed?
15716 C  no resonances for diquark-antidiquark and gluon-gluon strings
15717         IF(NCODE(I).EQ.5) THEN
15718           IF(CMASS0.LT.1.3D0*AM1) THEN
15719             IF(ISWMDL(7).LE.2) THEN
15720               IBHAD(I) = 90
15721               NNCH(I)  = -1
15722               CHMASS   = AM1*1.3D0
15723             ELSE
15724               IREJ = 1
15725               RETURN
15726             ENDIF
15727           ENDIF
15728         ELSE
15729           INEED = 0
15730 C  resonances possible
15731           IF(ISWMDL(7).EQ.0) THEN
15732             IF(CMASS0.LT.AM1*0.99D0) THEN
15733               IBHAD(I) = IP1
15734               NNCH(I)  = -1
15735               CHMASS   = AM1
15736               INEED = 1
15737             ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15738               DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15739               DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15740               IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15741                 IBHAD(I) = IP1
15742                 NNCH(I)  = -1
15743                 CHMASS   = AM1
15744               ELSE
15745                 IBHAD(I) = IP2
15746                 NNCH(I)  = 1
15747                 CHMASS   = AM3
15748               ENDIF
15749             ENDIF
15750           ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15751             IF(CMASS0.LT.AM1*0.99) THEN
15752               IBHAD(I) = IP1
15753               NNCH(I) = -1
15754               CHMASS = AM1
15755               INEED = 1
15756             ENDIF
15757           ELSE IF(ISWMDL(7).EQ.3) THEN
15758             IF(CMASS0.LT.AM1) THEN
15759               IREJ = 1
15760               RETURN
15761             ENDIF
15762           ELSE
15763             WRITE(LO,'(/1X,A,I5)')
15764      &        'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15765             CALL PHO_ABORT
15766           ENDIF
15767         ENDIF
15768 C
15769 C  correction necessary?
15770         IF(IBHAD(I).NE.0) THEN
15771 C  find largest invar. mass
15772           IPOS = 0
15773           CMASS1 = -1.D0
15774           DO 200 J2=NHEP,3,-1
15775
15776             IF(ABS(ISTHEP(J2)).EQ.1) THEN
15777               IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15778                 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15779      &            'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15780                 CALL PHO_PREVNT(0)
15781               ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15782                 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15783      &                 -(PHEP(1,J1)+PHEP(1,J2))**2
15784      &                 -(PHEP(2,J1)+PHEP(2,J2))**2
15785      &                 -(PHEP(3,J1)+PHEP(3,J2))**2
15786                 IF(CMASS2.GT.CMASS1) THEN
15787                   IPOS=J2
15788                   CMASS1=CMASS2
15789                 ENDIF
15790               ENDIF
15791             ENDIF
15792
15793  200      CONTINUE
15794           J2 = IPOS
15795           IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15796             IF(INEED.EQ.1) THEN
15797               IREJ = 1
15798               RETURN
15799             ELSE
15800               IBHAD(I) = 0
15801               NNCH(I) = 0
15802               GOTO 90
15803             ENDIF
15804           ENDIF
15805           ISTA = ISTHEP(J1)
15806           ISTB = ISTHEP(J2)
15807           CMASS1 = SQRT(CMASS1)
15808           CMASS2 = PHEP(5,J2)
15809           IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15810           IREJ = 1
15811           IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15812      &      CHMASS,CMASS2,PC1,PC2,IREJ)
15813           IF(IREJ.NE.0) THEN
15814             IFAIL(24) = IFAIL(24)+1
15815             IF(IDEB(42).GE.2) THEN
15816               WRITE(LO,'(1X,A,2I4)')
15817      &          'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15818               IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15819             ENDIF
15820             IREJ = 1
15821             RETURN
15822           ENDIF
15823 C  momentum transfer
15824           DO 210 II=1,4
15825             PTR(II) = PHEP(II,J2)-PC2(II)
15826  210      CONTINUE
15827           IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15828      &      'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15829 C  copy parents of strings
15830 C  register partons belonging to first string
15831           IF(IDHEP(J1).EQ.90) THEN
15832             K1 = JMOHEP(1,J1)
15833             K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15834             ESUM = 0.D0
15835             DO 500 II=K1,K2
15836               ESUM = ESUM+PHEP(4,II)
15837  500        CONTINUE
15838             IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15839             DO 600 II=K1,K2
15840               FAC = PHEP(4,II)/ESUM
15841               DO 650 K=1,4
15842                 P1(K) = PHEP(K,II)+FAC*PTR(K)
15843  650          CONTINUE
15844               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15845      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15846      &          ICOLOR(2,II),IPOS,1)
15847  600        CONTINUE
15848             K1A = IPOS+K1-K2
15849             IF(JMOHEP(2,J1).GT.0) THEN
15850               II = JMOHEP(2,J1)
15851               FAC = PHEP(4,II)/ESUM
15852               DO 675 K=1,4
15853                 P1(K) = PHEP(K,II)+FAC*PTR(K)
15854  675          CONTINUE
15855               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15856      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15857      &          ICOLOR(2,II),IPOS,1)
15858             ENDIF
15859             K2A = -IPOS
15860           ELSE
15861             K1A = J1
15862             K2A = J2
15863           ENDIF
15864 C  register partons belonging to second string
15865           IF(IDHEP(J2).EQ.90) THEN
15866             CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15867             K1 = JMOHEP(1,J2)
15868             K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15869             ESUM = 0.D0
15870             DO 300 II=K1,K2
15871               ESUM = ESUM+PHEP(4,II)
15872  300        CONTINUE
15873             IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15874             DO 400 II=K1,K2
15875               FAC = PHEP(4,II)/ESUM
15876               IF(IREJL.EQ.0) THEN
15877                 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15878                 P1(4) = P1(4)+FAC*DELE
15879               ELSE
15880                 DO 450 K=1,4
15881                   P1(K) = PHEP(K,II)-FAC*PTR(K)
15882  450            CONTINUE
15883               ENDIF
15884               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15885      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15886      &          ICOLOR(2,II),IPOS,1)
15887  400        CONTINUE
15888             K1B = IPOS+K1-K2
15889             IF(JMOHEP(2,J2).GT.0) THEN
15890               II = JMOHEP(2,J2)
15891               FAC = PHEP(4,II)/ESUM
15892               IF(IREJL.EQ.0) THEN
15893                 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15894                 P1(4) = P1(4)+FAC*DELE
15895               ELSE
15896                 DO 475 K=1,4
15897                   P1(K) = PHEP(K,II)-FAC*PTR(K)
15898  475            CONTINUE
15899               ENDIF
15900               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15901      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15902      &          ICOLOR(2,II),IPOS,1)
15903             ENDIF
15904             K2B = -IPOS
15905           ELSE
15906             K1B = J1
15907             K2B = J2
15908           ENDIF
15909 C  register first string/collapsed to hadron
15910           IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
15911             IF(NCODE(I).NE.5) THEN
15912               CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
15913      &          PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15914 C  label string as collapsed to hadron/resonance
15915               NCODE(I)  = -99
15916               IDHEP(J1) = 92
15917             ELSE
15918               CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
15919      &          PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15920               IDHEP(J1) = 91
15921             ENDIF
15922             NPOS(1,I) = IPOS
15923             NPOS(2,I) = K1A
15924             NPOS(3,I) = K2A
15925           ELSE
15926             CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
15927      &        PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
15928      &        ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
15929             IF(IDHEP(J1).EQ.90) THEN
15930               NPOS(1,IPHIST(1,J1)) = IPOS
15931               NPOS(2,IPHIST(1,J1)) = K1A
15932               NPOS(3,IPHIST(1,J1)) = K2A
15933 C  label string as collapsed to resonance-string
15934               IDHEP(J1) = 91
15935             ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
15936               IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
15937             ENDIF
15938           ENDIF
15939 C  register second string/hadron/parton
15940           CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
15941      &      PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
15942      &      ICOLOR(2,J2),IPOS,1)
15943           IF(IDHEP(J2).EQ.90) THEN
15944             NPOS(1,IPHIST(1,J2))=IPOS
15945             NPOS(2,IPHIST(1,J2))=K1B
15946             NPOS(3,IPHIST(1,J2))=K2B
15947 C  label string touched by momentum transfer
15948             IDHEP(J2) = 91
15949           ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
15950             IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
15951           ENDIF
15952           ICCOR = ICCOR+1
15953           ITOUCH = ITOUCH+1
15954 C  consistency checks
15955           IF(IDEB(42).GE.5) THEN
15956             CALL PHO_CHECK(-1,IDEV)
15957             IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
15958           ENDIF
15959 C  jump to next iteration
15960           GOTO 50
15961         ENDIF
15962  90     CONTINUE
15963  100  CONTINUE
15964 C  debug output
15965       IF(IDEB(42).GE.15) THEN
15966         IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
15967           WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
15968           CALL PHO_PREVNT(1)
15969         ENDIF
15970       ENDIF
15971       END
15972
15973 CDECK  ID>, PHO_PARCOR
15974       SUBROUTINE PHO_PARCOR(MODE,IREJ)
15975 C********************************************************************
15976 C
15977 C    conversion of string partons (using JETSET masses)
15978 C
15979 C    input:      MODE    >0 position index of corresponding string
15980 C                        -1 initialization
15981 C                        -2 output of statistics
15982 C
15983 C    output:     /POSTRG/
15984 C                IREJ    1 combination of strings impossible
15985 C                        0 successful combination
15986 C
15987 C********************************************************************
15988       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15989       SAVE
15990
15991       PARAMETER ( DELM   =  0.005D0,
15992      &            DEPS   =  1.D-15,
15993      &            EPS    =  1.D-5)
15994
15995 C  input/output channels
15996       INTEGER LI,LO
15997       COMMON /POINOU/ LI,LO
15998 C  event debugging information
15999       INTEGER NMAXD
16000       PARAMETER (NMAXD=100)
16001       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16002      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16003       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16004      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16005 C  internal rejection counters
16006       INTEGER NMXJ
16007       PARAMETER (NMXJ=60)
16008       CHARACTER*10 REJTIT
16009       INTEGER IFAIL
16010       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16011 C  model switches and parameters
16012       CHARACTER*8 MDLNA
16013       INTEGER ISWMDL,IPAMDL
16014       DOUBLE PRECISION PARMDL
16015       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16016
16017 C  standard particle data interface
16018       INTEGER NMXHEP
16019
16020       PARAMETER (NMXHEP=4000)
16021
16022       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16023       DOUBLE PRECISION PHEP,VHEP
16024       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16025      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16026      &                VHEP(4,NMXHEP)
16027 C  extension to standard particle data interface (PHOJET specific)
16028       INTEGER IMPART,IPHIST,ICOLOR
16029       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16030
16031 C  color string configurations including collapsed strings and hadrons
16032       INTEGER MSTR
16033       PARAMETER (MSTR=500)
16034       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16035       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16036      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16037      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16038
16039       DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16040      &          PL(4,100),XMP(100),XML(100)
16041
16042       DOUBLE PRECISION PYMASS
16043
16044       IREJ = 0
16045       IMODE = MODE
16046 C
16047       IF(IMODE.GT.0) THEN
16048         ICH = 0
16049         I1 = JMOHEP(1,IMODE)
16050         I2 = ABS(JMOHEP(2,IMODE))
16051 C  copy to local field
16052         L = 0
16053         DO 100 I=I1,I2
16054           L = L+1
16055           DO 200 K=1,4
16056             PL(K,L) = PHEP(K,I)
16057  200      CONTINUE
16058           XMP(L) = PHEP(5,I)
16059
16060           XML(L) = PYMASS(IDHEP(I))
16061
16062  100    CONTINUE
16063         IPAR = L
16064         XMC = PHEP(5,IMODE)
16065         IF(IDEB(82).GE.20) THEN
16066           WRITE(LO,'(1X,A,I7,2I4)')
16067      &      'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16068      &      KEVENT,IMODE,L
16069           DO 150 I=1,L
16070             WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16071      &       XMP(I),XML(I)
16072  150      CONTINUE
16073         ENDIF
16074 C
16075 C  two parton configurations
16076 C  -----------------------------------------
16077         IF(IPAR.EQ.2) THEN
16078           XM1 = XML(1)
16079           XM2 = XML(2)
16080           IF((XM1+XM2).GE.XMC) THEN
16081             IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16082      &        'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16083      &        IMODE,XM1,XM2,XMC
16084             GOTO 990
16085           ENDIF
16086 C  conversion possible
16087           CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16088           IF(IREJ.NE.0) THEN
16089             IFAIL(36) = IFAIL(36)+1
16090             IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16091      &      'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16092      &        KEVENT,IMODE,XMC
16093             GOTO 990
16094           ENDIF
16095           ICH = 1
16096           DO 115 K=1,4
16097             PL(K,1) = PP1(K)
16098             PL(K,2) = PP2(K)
16099             XMP(1) = XM1
16100             XMP(2) = XM2
16101  115      CONTINUE
16102 C
16103 C  multi parton configurations
16104 C  ---------------------------------
16105         ELSE
16106 C
16107 C  random selection of string side to start with
16108           IF(DT_RNDM(XMC).LT.0.5D0) THEN
16109             K1 = 1
16110             K2 = IPAR
16111             KS = 1
16112           ELSE
16113             K1 = IPAR
16114             K2 = 1
16115             KS = -1
16116           ENDIF
16117           ITER = 0
16118 C
16119  300      CONTINUE
16120           IF(ITER.LT.4) THEN
16121             KK = K1
16122             K1 = K2
16123             K2 = KK
16124             KS = -KS
16125           ELSE
16126             GOTO 990
16127           ENDIF
16128           ITER = ITER+1
16129 C  select method
16130           IF(ITER.GT.2) GOTO 230
16131
16132 C  conversion according to color flow method
16133           IFAI = 0
16134           DO 210 II=K1,K2-KS,KS
16135             DO 215 IK=II+KS,K2,KS
16136               XM1 = XML(II)
16137               XM2 = XML(IK)
16138 *             IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16139 *    &          'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16140               IF((ABS(XM1-XMP(II)).GT.DELM)
16141      &           .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16142                 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16143                 IF(IREJ.NE.0) THEN
16144                   IFAIL(36) = IFAIL(36)+1
16145                   IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16146      &              'PHO_PARCOR: ',
16147      &              'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16148      &              KEVENT,IMODE,II,IK
16149                   IREJ = 0
16150                 ELSE
16151                   ICH = ICH+1
16152                   DO 220 KK=1,4
16153                     PL(KK,II) = PP1(KK)
16154                     PL(KK,IK) = PP2(KK)
16155  220              CONTINUE
16156                   XMP(II) = XM1
16157                   XMP(IK) = XM2
16158                   GOTO 219
16159                 ENDIF
16160               ELSE
16161                 GOTO 219
16162               ENDIF
16163  215        CONTINUE
16164             IFAI = II
16165  219        CONTINUE
16166  210      CONTINUE
16167           IF(IFAI.NE.0) GOTO 300
16168           GOTO 950
16169 C
16170  230      CONTINUE
16171 C
16172 C  conversion according to remainder method
16173           DO 350 I=K1,K2,KS
16174             XM1 = XML(I)
16175             IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16176               ICH = ICH+1
16177               IFAI = I
16178 C  conversion necessary
16179               DO 400 K=1,4
16180                 PB1(K) = PL(K,I)
16181                 PB2(K) = PHEP(K,IMODE)-PB1(K)
16182  400          CONTINUE
16183               XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16184               IF(XM2.LT.0.D0) THEN
16185                 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16186      &            'PHO_PARCOR: ',
16187      &            'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16188      &            I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16189                 GOTO 300
16190               ENDIF
16191               XM2 = SQRT(XM2)
16192               IF((XM1+XM2).GE.XMC) THEN
16193                 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16194      &            'PHO_PARCOR: ',
16195      &            'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16196      &            I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16197                 GOTO 300
16198               ENDIF
16199 C  conversion possible
16200               CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16201               IF(IREJ.NE.0) THEN
16202                 IFAIL(36) = IFAIL(36)+1
16203                 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16204      &            'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16205      &            ITER,IMODE,I
16206                 GOTO 300
16207               ENDIF
16208 C  calculate Lorentz transformation
16209               CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16210               IF(IREJ.NE.0) THEN
16211                 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16212      &            'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16213      &            ITER,IMODE,I
16214                 GOTO 300
16215               ENDIF
16216               IFAI = 0
16217 C  transform remaining partons
16218               DO 450 L=K1,K2,KS
16219                 IF(L.NE.I) THEN
16220                   CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16221                   DO 500 K=1,4
16222                     PL(K,L) = PP2(K)
16223  500              CONTINUE
16224                 ELSE
16225                   DO 550 K=1,4
16226                     PL(K,L) = PP1(K)
16227  550              CONTINUE
16228                 ENDIF
16229  450          CONTINUE
16230               XMP(I) = XM1
16231             ENDIF
16232  350      CONTINUE
16233         ENDIF
16234
16235 C  register transformed partons
16236  950      CONTINUE
16237           IREJ = 0
16238           IF(ICH.NE.0) THEN
16239             IP1 = NHEP+1
16240             L = 0
16241             DO 700 I=I1,I2
16242               L= L+1
16243               CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16244      &          PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16245      &          ICOLOR(2,I),IPOS,1)
16246  700        CONTINUE
16247             IP2 = IPOS
16248 C  register string
16249             CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16250      &        PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16251      &        IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16252 C  update /POSTRG/
16253             I = IPHIST(1,IMODE)
16254             NPOS(1,I) = IPOS
16255             NPOS(2,I) = IP1
16256             NPOS(3,I) = -IP2
16257           ENDIF
16258 C  debug output
16259           IF(IDEB(82).GE.20) THEN
16260             WRITE(LO,'(1X,A,I7,2I4)')
16261      &        'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16262      &        KEVENT,IMODE,L
16263             DO 850 I=1,L
16264               WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16265      &         XMP(I),XML(I)
16266  850        CONTINUE
16267             WRITE(LO,'(1X,A,2I5)')
16268      &        'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16269           ENDIF
16270           RETURN
16271 C  rejection
16272  990      CONTINUE
16273           IREJ = 1
16274           IF(IDEB(82).GE.3) THEN
16275             WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16276      &        'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16277      &         IFAI,IPAR,IMODE,XMC
16278             IF(IDEB(82).GE.5) THEN
16279               WRITE(LO,'(1X,A,I7,2I4)')
16280      &          'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16281      &          KEVENT,IMODE,IPAR
16282               DO 155 I=1,IPAR
16283                 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16284      &           XMP(I),XML(I)
16285  155          CONTINUE
16286             ENDIF
16287           ENDIF
16288           RETURN
16289
16290       ELSE IF(IMODE.EQ.-1) THEN
16291 C  initialization
16292         RETURN
16293
16294       ELSE IF(IMODE.EQ.-2) THEN
16295 C  final output
16296         RETURN
16297       ENDIF
16298       END
16299
16300 CDECK  ID>, PHO_STRING
16301       SUBROUTINE PHO_STRING(IMODE,IREJ)
16302 C********************************************************************
16303 C
16304 C    calculation of string combinatorics, Lorentz boosts and
16305 C                   particle codes
16306 C
16307 C                - splitting of gluons
16308 C                - strings will be built up from pairs of partons
16309 C                  according to their color labels
16310 C                  with IDHEP(..) = -1
16311 C                - there can be other particles between to string partons
16312 C                  (these will be unchanged by string construction)
16313 C                - string mass fine correction
16314 C
16315 C    input:      IMODE    1  complete string processing
16316 C                        -1 initialization
16317 C                        -2 output of statistics
16318 C
16319 C    output:     /POSTRG/
16320 C                IREJ    1 combination of strings impossible
16321 C                        0 successful combination
16322 C                       50 rejection due to user cutoffs
16323 C
16324 C********************************************************************
16325       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16326       SAVE
16327
16328       PARAMETER ( DEPS   =  1.D-15,
16329      &            EPS    =  1.D-5 )
16330
16331 C  input/output channels
16332       INTEGER LI,LO
16333       COMMON /POINOU/ LI,LO
16334 C  event debugging information
16335       INTEGER NMAXD
16336       PARAMETER (NMAXD=100)
16337       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16338      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16339       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16340      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16341 C  general process information
16342       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16343       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16344 C  internal rejection counters
16345       INTEGER NMXJ
16346       PARAMETER (NMXJ=60)
16347       CHARACTER*10 REJTIT
16348       INTEGER IFAIL
16349       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16350 C  model switches and parameters
16351       CHARACTER*8 MDLNA
16352       INTEGER ISWMDL,IPAMDL
16353       DOUBLE PRECISION PARMDL
16354       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16355 C  hard cross sections and MC selection weights
16356       INTEGER Max_pro_2
16357       PARAMETER ( Max_pro_2 = 16 )
16358       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16359      &  MH_acc_1,MH_acc_2
16360       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16361       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16362      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16363      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16364      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16365      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16366
16367 C  standard particle data interface
16368       INTEGER NMXHEP
16369
16370       PARAMETER (NMXHEP=4000)
16371
16372       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16373       DOUBLE PRECISION PHEP,VHEP
16374       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16375      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16376      &                VHEP(4,NMXHEP)
16377 C  extension to standard particle data interface (PHOJET specific)
16378       INTEGER IMPART,IPHIST,ICOLOR
16379       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16380
16381 C  color string configurations including collapsed strings and hadrons
16382       INTEGER MSTR
16383       PARAMETER (MSTR=500)
16384       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16385       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16386      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16387      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16388 C  table of particle indices for recursive PHOJET calls
16389       INTEGER MAXIPX
16390       PARAMETER ( MAXIPX = 100 )
16391       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16392       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16393      &                IPOIX1,IPOIX2,IPOIX3
16394 C  some constants
16395       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16396       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16397      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16398
16399       IREJ = 0
16400       IF(IMODE.EQ.-1) THEN
16401         CALL PHO_POMCOR(-1)
16402         CALL PHO_MASCOR(-1)
16403         CALL PHO_PARCOR(-1,IREJ)
16404
16405         RETURN
16406       ELSE IF(IMODE.EQ.-2) THEN
16407         CALL PHO_POMCOR(-2)
16408         CALL PHO_MASCOR(-2)
16409         CALL PHO_PARCOR(-2,IREJ)
16410
16411         RETURN
16412       ENDIF
16413
16414 C  generate enhanced graphs
16415       IF(IPOIX2.GT.0) THEN
16416  200    CONTINUE
16417         I1 = MAX(1,IPOIX1)
16418         I2 = IPOIX2
16419         IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16420         KSPOMS = KSPOM-1
16421         KSREGS = KSREG
16422         KHPOMS = KHPOM
16423         KHDIRS = KHDIR
16424         IDDFS1 = IDIFR1
16425         IDDFS2 = IDIFR2
16426         IDDPOS = IDDPOM
16427         DO 110 I=I1,I2
16428           IPOIX3 = I
16429           KSPOM = 0
16430           KSREG = 0
16431           KHPOM = 0
16432           KHDIR = 0
16433           IF(IPORES(I).EQ.8) THEN
16434             KSPOM = 2
16435             LSPOM = 2
16436             LHPOM = 0
16437             LSREG = 0
16438             LHDIR = 0
16439             IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16440             CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16441      &                      LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16442             IF(IREJ.NE.0) THEN
16443               IF(IDEB(4).GE.2) THEN
16444                 WRITE(LO,'(/1X,A,I5)')
16445      &            'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16446                 CALL PHO_PREVNT(-1)
16447               ENDIF
16448               RETURN
16449             ENDIF
16450             KSPOM = KSPOMS+LSPOM
16451             KSREG = KSREGS+LSREG
16452             KHPOM = KHPOMS+LHPOM
16453             KHDIR = KHDIRS+LHDIR
16454           ELSE IF(IPORES(I).EQ.4) THEN
16455             ITEMP = ISWMDL(17)
16456             ISWMDL(17) = 0
16457             CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16458             ISWMDL(17) = ITEMP
16459             IF(IREJ.NE.0) THEN
16460               IF(IDEB(4).GE.2) THEN
16461                 WRITE(LO,'(/1X,A,I5)')
16462      &            'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16463                 CALL PHO_PREVNT(-1)
16464               ENDIF
16465               RETURN
16466             ENDIF
16467             KSDPO = KSDPO+1
16468             KSPOM = KSPOMS+KSPOM
16469             KSREG = KSREGS+KSREG
16470             KHPOM = KHPOMS+KHPOM
16471             KHDIR = KHDIRS+KHDIR
16472           ELSE
16473             IDIF1 = 1
16474             IDIF2 = 1
16475             IF(IPORES(I).EQ.5) THEN
16476               IDIF2 = 0
16477               KSTRG = KSTRG+1
16478             ELSE IF(IPORES(I).EQ.6) THEN
16479               IDIF1 = 0
16480               KSTRG = KSTRG+1
16481             ELSE
16482               KSLOO = KSLOO+1
16483             ENDIF
16484             ITEMP = ISWMDL(16)
16485             ISWMDL(16) = 0
16486             SPROB = 1.D0
16487             CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16488      &        0,MSOFT,MHARD,IREJ)
16489             ISWMDL(16) = ITEMP
16490             IF(IREJ.NE.0) THEN
16491               IF(IDEB(4).GE.2) THEN
16492                 WRITE(LO,'(/1X,A,I5)')
16493      &            'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16494                 CALL PHO_PREVNT(-1)
16495               ENDIF
16496               RETURN
16497             ENDIF
16498             KSPOM = KSPOMS+KSPOM
16499             KSREG = KSREGS+KSREG
16500             KHPOM = KHPOMS+KHPOM
16501             KHDIR = KHDIRS+KHDIR
16502           ENDIF
16503           IDIFR1 = IDDFS1
16504           IDIFR2 = IDDFS2
16505           IDDPOM = IDDPOS
16506  110    CONTINUE
16507         IF(IPOIX2.GT.I2) THEN
16508           IPOIX1 = I2+1
16509           GOTO 200
16510         ENDIF
16511       ENDIF
16512
16513 C  optional: split gluons to q-qbar pairs
16514       IF(ISWMDL(9).GT.0) THEN
16515         NHEPO = NHEP
16516         DO 30 I=3,NHEPO
16517           IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16518             ICG1=ICOLOR(1,I)
16519             ICG2=ICOLOR(2,I)
16520             IQ1 = 0
16521             IQ2 = 0
16522             DO 40 K=3,NHEPO
16523               IF(ICOLOR(1,K).EQ.-ICG1) THEN
16524                 IQ1 = K
16525                 IF(IQ1*IQ2.NE.0) GOTO 45
16526               ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16527                 IQ2 = K
16528                 IF(IQ1*IQ2.NE.0) GOTO 45
16529               ENDIF
16530  40         CONTINUE
16531             WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16532      &        'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16533             CALL PHO_ABORT
16534  45         CONTINUE
16535             CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16536             IF(IREJ.NE.0) THEN
16537               IF(IDEB(19).GE.5) THEN
16538                 WRITE(LO,'(/,1X,A)')
16539      &            'PHO_STRING: no gluon splitting possible'
16540                 CALL PHO_PREVNT(0)
16541               ENDIF
16542               RETURN
16543             ENDIF
16544           ENDIF
16545  30     CONTINUE
16546       ENDIF
16547
16548 C  construct strings and write entries sorted by strings
16549
16550       ISTR = ISTR+1
16551       NHEPO = NHEP
16552       DO 50 I=3,NHEPO
16553
16554         IF(ISTR.GT.MSTR) THEN
16555           WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16556      &      'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16557           CALL PHO_PREVNT(0)
16558           IREJ = 1
16559           RETURN
16560         ENDIF
16561
16562         IF(ISTHEP(I).EQ.1) THEN
16563 C  hadrons / resonances / clusters
16564           NPOS(1,ISTR) = I
16565           NPOS(2,ISTR) = 0
16566           NPOS(3,ISTR) = 0
16567           NPOS(4,ISTR) = abs(IPHIST(2,I))
16568           NCODE(ISTR) = -99
16569           IPHIST(1,I) = ISTR
16570           ISTR = ISTR+1
16571         ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16572 C  quark /diquark terminated strings
16573           ICOL1 = -ICOLOR(1,I)
16574           P1 = PHEP(1,I)
16575           P2 = PHEP(2,I)
16576           P3 = PHEP(3,I)
16577           P4 = PHEP(4,I)
16578           ICH1 = IPHO_CHR3(I,2)
16579           IBA1 = IPHO_BAR3(I,2)
16580           CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16581      &                P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16582      &                ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16583           JM1 = IPOS
16584
16585           NRPOM = 0
16586  65       CONTINUE
16587           DO 55 K=3,NHEPO
16588             IF(ISTHEP(K).EQ.-1)THEN
16589               IF(IDHEP(K).EQ.21) THEN
16590                 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16591                   ICOL1 = -ICOLOR(2,K)
16592                   GOTO 60
16593                 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16594                   ICOL1 = -ICOLOR(1,K)
16595                   GOTO 60
16596                 ENDIF
16597               ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16598                 ICOL1 = 0
16599                 GOTO 60
16600               ENDIF
16601             ENDIF
16602  55       CONTINUE
16603           WRITE(LO,'(/1X,A,I5)')
16604      &      'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16605           CALL PHO_ABORT
16606  60       CONTINUE
16607           P1 = P1+PHEP(1,K)
16608           P2 = P2+PHEP(2,K)
16609           P3 = P3+PHEP(3,K)
16610           P4 = P4+PHEP(4,K)
16611           NRPOM = MAX(NRPOM,IPHIST(1,K))
16612           ICH1 = ICH1+IPHO_CHR3(K,2)
16613           IBA1 = IBA1+IPHO_BAR3(K,2)
16614           CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16615      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16616      &      IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16617 C  further parton involved?
16618           IF(ICOL1.NE.0) GOTO 65
16619           JM2 = IPOS
16620 C  register string
16621           IGEN = IPHIST(2,K)
16622           CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16623      &                ISTR,IGEN,ICH1,IBA1,IPOS,1)
16624 C  store additional string information
16625           NPOS(1,ISTR) = IPOS
16626           NPOS(2,ISTR) = JM1
16627           NPOS(3,ISTR) = -JM2
16628           NPOS(4,ISTR) = abs(IPHIST(2,K))
16629 C  calculate CPC string codes
16630           CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16631      &                IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16632           ISTR = ISTR+1
16633         ENDIF
16634  50   CONTINUE
16635
16636       DO 150 I=3,NHEPO
16637
16638         IF(ISTR.GT.MSTR) THEN
16639           WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16640      &      'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16641           CALL PHO_PREVNT(0)
16642           IREJ = 1
16643           RETURN
16644         ENDIF
16645
16646         IF(ISTHEP(I).EQ.-1) THEN
16647 C  gluon loop-strings
16648           ICOL1 = -ICOLOR(1,I)
16649           P1 = PHEP(1,I)
16650           P2 = PHEP(2,I)
16651           P3 = PHEP(3,I)
16652           P4 = PHEP(4,I)
16653           IBA1 = 0
16654           ICH1 = 0
16655           CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16656      &                P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16657      &                ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16658           JM1 = IPOS
16659 C
16660           NRPOM = 0
16661  165      CONTINUE
16662           IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16663           DO 155 K=I,NHEPO
16664             IF(ISTHEP(K).EQ.-1)THEN
16665               IF(ICOLOR(1,K).EQ.ICOL1) THEN
16666                 ICOL1 = -ICOLOR(2,K)
16667                 GOTO 160
16668               ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16669                 ICOL1 = -ICOLOR(1,K)
16670                 GOTO 160
16671               ENDIF
16672             ENDIF
16673  155      CONTINUE
16674           WRITE(LO,'(/1X,A,I5)')
16675      &      'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16676           CALL PHO_ABORT
16677  160      CONTINUE
16678           P1 = P1+PHEP(1,K)
16679           P2 = P2+PHEP(2,K)
16680           P3 = P3+PHEP(3,K)
16681           P4 = P4+PHEP(4,K)
16682           NRPOM = MAX(NRPOM,IPHIST(1,K))
16683           CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16684      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16685      &      IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16686 C  further parton involved?
16687           IF(ICOL1.NE.0) GOTO 165
16688  170      CONTINUE
16689           JM2 = IPOS
16690 C  register string
16691           IGEN = IPHIST(2,K)
16692           CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16693      &                ISTR,IGEN,ICH1,IBA1,IPOS,1)
16694 C  store additional string information
16695           NPOS(1,ISTR) = IPOS
16696           NPOS(2,ISTR) = JM1
16697           NPOS(3,ISTR) = -JM2
16698           NPOS(4,ISTR) = abs(IPHIST(2,K))
16699 C  calculate CPC string codes
16700           CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16701      &                IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16702           ISTR = ISTR+1
16703         ENDIF
16704  150  CONTINUE
16705
16706       ISTR = ISTR-1
16707
16708       IF(IDEB(19).GE.17) THEN
16709         WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16710         CALL PHO_PREVNT(0)
16711       ENDIF
16712
16713 C  pomeron corrections
16714       CALL PHO_POMCOR(IREJ)
16715       IF(IREJ.NE.0) THEN
16716         IFAIL(38) = IFAIL(38)+1
16717         IF(IDEB(19).GE.3) THEN
16718           WRITE(LO,'(1X,A,I6)')
16719      &      'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16720           CALL PHO_PREVNT(-1)
16721         ENDIF
16722         RETURN
16723       ENDIF
16724
16725 C  string mass corrections
16726       CALL PHO_MASCOR(IREJ)
16727       IF(IREJ.NE.0) THEN
16728         IFAIL(34) = IFAIL(34)+1
16729         IF(IDEB(19).GE.3) THEN
16730           WRITE(LO,'(1X,A,I6)')
16731      &      'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16732           CALL PHO_PREVNT(-1)
16733         ENDIF
16734         RETURN
16735       ENDIF
16736
16737 C  parton mass corrections
16738       DO 100 I=1,ISTR
16739         IF(NCODE(I).GE.0) THEN
16740           CALL PHO_PARCOR(NPOS(1,I),IREJ)
16741           IF(IREJ.NE.0) THEN
16742             IFAIL(35) = IFAIL(35)+1
16743             IF(IDEB(19).GE.3) THEN
16744               WRITE(LO,'(1X,A,I6)')
16745      &          'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16746               CALL PHO_PREVNT(-1)
16747             ENDIF
16748             RETURN
16749           ENDIF
16750         ENDIF
16751  100  CONTINUE
16752
16753 C  statistics of hard processes
16754       DO 550 I=3,NHEP
16755         IF(ISTHEP(I).EQ.25) THEN
16756           K  = IMPART(I)
16757           II = IDHEP(I)
16758           MH_acc_2(K,II) = MH_acc_2(K,II)+1
16759         ENDIF
16760  550  CONTINUE
16761
16762 C  debug: write out strings
16763       IF(IDEB(19).GE.5) THEN
16764         IF(IDEB(19).GE.10)
16765      &    CALL PHO_CHECK(1,IDEV)
16766         IF(IDEB(19).GE.15) THEN
16767           CALL PHO_PREVNT(0)
16768         ELSE
16769           CALL PHO_PRSTRG
16770         ENDIF
16771       ENDIF
16772
16773       END
16774
16775 CDECK  ID>, PHO_STRFRA
16776       SUBROUTINE PHO_STRFRA(IREJ)
16777 C********************************************************************
16778 C
16779 C     do all fragmentation of strings
16780 C
16781 C     output:  IREJ    0   successful
16782 C                      1   rejection
16783 C                     50   rejection due to user cutoffs
16784 C
16785 C********************************************************************
16786
16787       IMPLICIT NONE
16788
16789       SAVE
16790
16791 C  input/output channels
16792       INTEGER LI,LO
16793       COMMON /POINOU/ LI,LO
16794 C  some constants
16795       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16796       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16797      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16798 C  event debugging information
16799       INTEGER NMAXD
16800       PARAMETER (NMAXD=100)
16801       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16802      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16803       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16804      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16805 C  general process information
16806       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16807       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16808 C  model switches and parameters
16809       CHARACTER*8 MDLNA
16810       INTEGER ISWMDL,IPAMDL
16811       DOUBLE PRECISION PARMDL
16812       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16813 C  global event kinematics and particle IDs
16814       INTEGER IFPAP,IFPAB
16815       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16816       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16817
16818 C  standard particle data interface
16819       INTEGER NMXHEP
16820
16821       PARAMETER (NMXHEP=4000)
16822
16823       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16824       DOUBLE PRECISION PHEP,VHEP
16825       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16826      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16827      &                VHEP(4,NMXHEP)
16828 C  extension to standard particle data interface (PHOJET specific)
16829       INTEGER IMPART,IPHIST,ICOLOR
16830       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16831
16832 C  color string configurations including collapsed strings and hadrons
16833       INTEGER MSTR
16834       PARAMETER (MSTR=500)
16835       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16836       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16837      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16838      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16839
16840       INTEGER IREJ
16841
16842       DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16843
16844       INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16845      &        IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16846
16847       integer indx(500),indx_max
16848
16849       DOUBLE PRECISION DT_RNDM
16850       INTEGER ipho_pdg2id
16851       EXTERNAL DT_RNDM,ipho_pdg2id
16852
16853       DOUBLE PRECISION PYP,RQLUN
16854       INTEGER PYK
16855
16856       INTEGER MSTU,MSTJ
16857       DOUBLE PRECISION PARU,PARJ
16858       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16859
16860       INTEGER N,NPAD,K
16861       DOUBLE PRECISION P,V
16862       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16863
16864       DIMENSION IJOIN(100)
16865
16866       IREJ = 0
16867       IF(ABS(ISWMDL(6)).GT.3) THEN
16868         WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16869      &    'invalid value of ISWMDL(6)',ISWMDL(6)
16870         CALL PHO_ABORT
16871       ENDIF
16872
16873 C  popcorn suppression
16874         IF(PARMDL(134).GT.0.D0) THEN
16875           IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16876             MSTJ(12) = 2
16877           ELSE
16878             MSTJ(12) = 1
16879           ENDIF
16880         ENDIF
16881
16882 C  copy partons to fragmentation code JETSET
16883         IP = 0
16884         IP_old = 1
16885
16886         DO 300 J=1,ISTR
16887
16888 C  select partons with common production process
16889           IGEN = NPOS(4,J)
16890           if(IGEN.lt.0) goto 299
16891
16892           indx_max = 0
16893           DO 400 I=J,ISTR
16894             if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
16895
16896 C  write final particles/resonances to JETSET
16897               IF(NCODE(I).EQ.-99) THEN
16898                 II = NPOS(1,I)
16899                 IP = IP+1
16900                 P(IP,1) = PHEP(1,II)
16901                 P(IP,2) = PHEP(2,II)
16902                 P(IP,3) = PHEP(3,II)
16903                 P(IP,4) = PHEP(4,II)
16904                 P(IP,5) = PHEP(5,II)
16905                 K(IP,1) = 1
16906                 K(IP,2) = IDHEP(II)
16907                 K(IP,3) = 0
16908                 K(IP,4) = 0
16909                 K(IP,5) = 0
16910                 IPHIST(2,II) = IP
16911
16912                 if(indx_max.eq.500) then
16913                   WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
16914      &              'no space left in index vector (indx,Kevent)',
16915      &              indx_max,KEVENT
16916                   IREJ = 1
16917                   return
16918                 endif
16919
16920                 indx_max = indx_max+1
16921                 indx(indx_max) = II
16922 C  write partons to JETSET
16923               ELSE IF(NCODE(I).GE.0) THEN
16924                 K1 = JMOHEP(1,NPOS(1,I))
16925                 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
16926                 IJ = 0
16927                 DO II=K1,K2
16928                   IP = IP+1
16929                   P(IP,1) = PHEP(1,II)
16930                   P(IP,2) = PHEP(2,II)
16931                   P(IP,3) = PHEP(3,II)
16932                   P(IP,4) = PHEP(4,II)
16933                   P(IP,5) = PHEP(5,II)
16934                   K(IP,1) = 1
16935                   K(IP,2) = IDHEP(II)
16936                   K(IP,3) = 0
16937                   K(IP,4) = 0
16938                   K(IP,5) = 0
16939                   IPHIST(2,II) = IP
16940                   IJ = IJ+1
16941                   IJOIN(IJ) = IP
16942                   indx_max = indx_max+1
16943                   indx(indx_max) = II
16944
16945                 ENDDO
16946                 II = JMOHEP(2,NPOS(1,I))
16947                 IF((II.GT.0).AND.(II.NE.K1)) THEN
16948                   IP = IP+1
16949                   P(IP,1) = PHEP(1,II)
16950                   P(IP,2) = PHEP(2,II)
16951                   P(IP,3) = PHEP(3,II)
16952                   P(IP,4) = PHEP(4,II)
16953                   P(IP,5) = PHEP(5,II)
16954                   K(IP,1) = 1
16955                   K(IP,2) = IDHEP(II)
16956                   K(IP,3) = 0
16957                   K(IP,4) = 0
16958                   K(IP,5) = 0
16959                   IPHIST(2,II) = IP
16960                   IJ = IJ+1
16961                   IJOIN(IJ) = IP
16962                   indx_max = indx_max+1
16963                   indx(indx_max) = II
16964
16965                 ENDIF
16966                 N = IP
16967 C  connect partons to strings
16968
16969                 CALL PYJOIN(IJ,IJOIN)
16970
16971               ENDIF
16972
16973               NPOS(4,I) = -NPOS(4,I)
16974             endif
16975  400      continue
16976
16977 C  set Lund counter
16978           N = IP
16979           if(IP.eq.0) goto 299
16980
16981 C  hard final state evolution
16982           IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
16983             ISH = 0
16984             do 125 k1=1,indx_max
16985               I = indx(k1)
16986               IF(IPHIST(1,I).LE.-100) THEN
16987                 ISH = ISH+1
16988                 IJOIN(ISH) = I
16989               ENDIF
16990  125        continue
16991             IF(ISH.GE.2) THEN
16992               DO 130 K1=1,ISH
16993                 IF(IJOIN(K1).EQ.0) GOTO 130
16994                 I = IJOIN(K1)
16995                 IF((IPAMDL(102).EQ.1)
16996      &             .AND.(IPHIST(1,I).NE.-100)) GOTO 130
16997                 DO 135 K2=K1+1,ISH
16998                   IF(IJOIN(K2).EQ.0) GOTO 135
16999                   II = IJOIN(K2)
17000                   IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
17001                     PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
17002                     PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
17003                     RQLUN = MIN(PT1,PT2)
17004
17005                     IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
17006      &                'PHO_STRFRA: PYSHOW called',I,II,RQLUN
17007                     CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
17008
17009                     IJOIN(K1) = 0
17010                     IJOIN(K2) = 0
17011                     GOTO 130
17012                   ENDIF
17013  135            CONTINUE
17014  130          CONTINUE
17015             ENDIF
17016           ENDIF
17017
17018 C  fragment parton / hadron configuration (hadronization & decay)
17019
17020           IF(ISWMDL(6).NE.0) THEN
17021             II = MSTU(21)
17022             MSTU(21) = 1
17023
17024             CALL PYEXEC
17025
17026             MSTU(21) = II
17027 C  Lund warning?
17028             if(MSTU(28).ne.0) then
17029               IF(IDEB(22).GE.10) THEN
17030                 WRITE(LO,'(1X,A,I12,I3)')
17031      &            'PHO_STRFRA:(1) Lund code warning (EV/code)',
17032      &            KEVENT,MSTU(28)
17033                 CALL PHO_PREVNT(2)
17034               ENDIF
17035             endif
17036 C  event accepted?
17037             IF(MSTU(24).NE.0) THEN
17038               IF(IDEB(22).GE.2) THEN
17039                 WRITE(LO,'(1X,A,I12,I3)')
17040      &            'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
17041      &            KEVENT,MSTU(24)
17042                 CALL PHO_PREVNT(2)
17043               ENDIF
17044               IREJ = 1
17045               RETURN
17046             ENDIF
17047           ENDIF
17048
17049           IP = N
17050 C  change particle status in JETSET to avoid internal adjustments
17051           do k1=IP_old,IP
17052             K(k1,1) = K(k1,1)+1000
17053           enddo
17054           IP_old = IP+1
17055
17056  299      continue
17057  300    CONTINUE
17058
17059 C  restore original JETSET particle status codes
17060         do i=1,N
17061           K(i,1) = K(i,1)-1000
17062         enddo
17063
17064 *       IF(IDEB(22).GE.25) THEN
17065 *         WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17066 *    &      'particle/string system before fragmentation'
17067 *         CALL PHO_PREVNT(2)
17068 *       ENDIF
17069
17070 C  copy hadrons back to POEVT1 / POEVT2
17071
17072         IF(IP.GT.0) THEN
17073           NHEP1 = NHEP+1
17074
17075           NLINES = PYK(0,1)
17076
17077 C  copy hadrons back with full history information
17078           IF(IPAMDL(178).EQ.1) THEN
17079             DO 155 II=1,ISTR
17080               IF(NCODE(II).GE.0) THEN
17081                 K1 = IPHIST(2,NPOS(2,II))
17082                 K2 = IPHIST(2,-NPOS(3,II))
17083               ELSE IF(NCODE(II).EQ.-99) THEN
17084                 K1 = IPHIST(2,NPOS(1,II))
17085                 K2 = K1
17086               ELSE
17087                 GOTO 149
17088               ENDIF
17089               IFOUND = 0
17090               DO 160 J=1,NLINES
17091
17092                 IF(PYK(J,7).EQ.1) THEN
17093                   IPMOTH = PYK(J,15)
17094
17095                   IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17096
17097                     IBAM = ipho_pdg2id(PYK(J,8))
17098
17099                     IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17100                       IF(IDEB(22).GE.2) THEN
17101                         WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17102      &                    'LUND interface (1) rejection'
17103                         CALL PHO_PREVNT(2)
17104                       ENDIF
17105                       IREJ = 1
17106                       RETURN
17107                     ENDIF
17108                     IFOUND = IFOUND+1
17109
17110                     PX = PYP(J,1)
17111                     PY = PYP(J,2)
17112                     PZ = PYP(J,3)
17113                     HE = PYP(J,4)
17114                     XMB = PYP(J,5)**2
17115
17116 C  register parton/hadron
17117                     IS = 1
17118                     IF(IBAM.EQ.0) THEN
17119                       IF(ISWMDL(6).EQ.0) THEN
17120                         IS = -1
17121                       ELSE
17122                         IF(IDEB(22).GE.2) THEN
17123                           WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17124      &                      'LUND interface (2) rejection'
17125                           CALL PHO_PREVNT(2)
17126                         ENDIF
17127                         IREJ = 1
17128                         RETURN
17129                       ENDIF
17130                     ENDIF
17131
17132                     CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17133      &                PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17134
17135                     ISTHEP(IPOS) = 1
17136                   ENDIF
17137                 ENDIF
17138  160          CONTINUE
17139               IF(IFOUND.EQ.0) THEN
17140                 IF(IDEB(2).GE.2) THEN
17141                   WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17142      &            'no particles found for string (EVE,ISTR):',KEVENT,II
17143                 ENDIF
17144                 ISTHEP(NPOS(1,II)) = 2
17145               ENDIF
17146  149          CONTINUE
17147  155        CONTINUE
17148           ELSE
17149 C  copy hadrons back without history information
17150             JDAHEP(1,1) = NHEP1
17151             JDAHEP(1,2) = NHEP1
17152             DO 170 J=1,NLINES
17153
17154               IF(PYK(J,7).EQ.1) THEN
17155                 IBAM = ipho_pdg2id(PYK(J,8))
17156
17157                 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17158                   IF(IDEB(22).GE.2) THEN
17159                     WRITE(LO,'(/1X,A)')
17160      &                'PHO_STRFRA: LUND interface (3) rejection'
17161                     CALL PHO_PREVNT(2)
17162                   ENDIF
17163                   IREJ = 1
17164                   RETURN
17165                 ENDIF
17166
17167                 PX = PYP(J,1)
17168                 PY = PYP(J,2)
17169                 PZ = PYP(J,3)
17170                 HE = PYP(J,4)
17171                 XMB = PYP(J,5)**2
17172
17173 C  register parton/hadron
17174                 IS = 1
17175                 IF(IBAM.EQ.0) THEN
17176                   IF(ISWMDL(6).EQ.0) THEN
17177                     IS = -1
17178                   ELSE
17179                     IF(IDEB(22).GE.2) THEN
17180                       WRITE(LO,'(/1X,A)')
17181      &                  'PHO_STRFRA: LUND interface (4) rejection'
17182                       CALL PHO_PREVNT(2)
17183                     ENDIF
17184                     IREJ = 1
17185                     RETURN
17186                   ENDIF
17187                 ENDIF
17188
17189                 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17190      &            HE,J,0,0,0,IPOS,1)
17191
17192                 ISTHEP(IPOS) = 1
17193               ENDIF
17194  170        CONTINUE
17195             DO 180 II=1,ISTR
17196               IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17197      &          ISTHEP(NPOS(1,II)) = 2
17198  180        CONTINUE
17199           ENDIF
17200         ENDIF
17201
17202 C  debug event status
17203       IF(IDEB(22).GE.15) THEN
17204         WRITE(LO,'(//1X,A)')
17205      &    'PHO_STRFRA: particle system after fragmentation'
17206         CALL PHO_PREVNT(2)
17207       ENDIF
17208
17209       END
17210
17211 CDECK  ID>, PHO_EVEINI
17212       SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17213 C********************************************************************
17214 C
17215 C     prepare /POEVT1/ for new event
17216 C
17217 C     first subroutine called for each event
17218 C
17219 C     input:   P1(4)  particle 1
17220 C              P2(4)  particle 2
17221 C              IMODE  0    general initialization
17222 C                     1    initialization of particles and kinematics
17223 C                     2    initialization after internal rejection
17224 C
17225 C     output:  IP1,IP2  index of interacting particles
17226 C
17227 C********************************************************************
17228       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17229       SAVE
17230
17231       DIMENSION P1(4),P2(4)
17232
17233       PARAMETER ( EPS    =  1.D-5,
17234      &            DEPS   =  1.D-15 )
17235
17236 C  input/output channels
17237       INTEGER LI,LO
17238       COMMON /POINOU/ LI,LO
17239 C  event debugging information
17240       INTEGER NMAXD
17241       PARAMETER (NMAXD=100)
17242       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17243      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17244       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17245      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17246 C  model switches and parameters
17247       CHARACTER*8 MDLNA
17248       INTEGER ISWMDL,IPAMDL
17249       DOUBLE PRECISION PARMDL
17250       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17251 C  general process information
17252       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17253       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17254 C  gamma-lepton or gamma-hadron vertex information
17255       INTEGER IGHEL,IDPSRC,IDBSRC
17256       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17257      &                 RADSRC,AMSRC,GAMSRC
17258       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17259      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17260      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17261 C  global event kinematics and particle IDs
17262       INTEGER IFPAP,IFPAB
17263       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17264       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17265 C  energy-interpolation table
17266       INTEGER IEETA2
17267       PARAMETER ( IEETA2 = 20 )
17268       INTEGER ISIMAX
17269       DOUBLE PRECISION SIGTAB,SIGECM
17270       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17271 C  cross sections
17272       INTEGER IPFIL,IFAFIL,IFBFIL
17273       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17274      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17275      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17276      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17277      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17278       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17279      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17280      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17281      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17282      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17283      &                IPFIL,IFAFIL,IFBFIL
17284 C  color string configurations including collapsed strings and hadrons
17285       INTEGER MSTR
17286       PARAMETER (MSTR=500)
17287       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17288       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17289      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17290      &                NNCH(MSTR),IBHAD(MSTR),ISTR
17291
17292 C  standard particle data interface
17293       INTEGER NMXHEP
17294
17295       PARAMETER (NMXHEP=4000)
17296
17297       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17298       DOUBLE PRECISION PHEP,VHEP
17299       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17300      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17301      &                VHEP(4,NMXHEP)
17302 C  extension to standard particle data interface (PHOJET specific)
17303       INTEGER IMPART,IPHIST,ICOLOR
17304       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17305
17306 C  table of particle indices for recursive PHOJET calls
17307       INTEGER MAXIPX
17308       PARAMETER ( MAXIPX = 100 )
17309       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17310       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17311      &                IPOIX1,IPOIX2,IPOIX3
17312 C  event weights and generated cross section
17313       INTEGER IPOWGC,ISWCUT,IVWGHT
17314       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17315       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17316      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17317
17318       DIMENSION IM(2)
17319
17320 C  reset debug variables
17321       KSPOM  = 0
17322       KHPOM  = 0
17323       KSREG  = 0
17324       KHDIR  = 0
17325       KSTRG  = 0
17326       KHTRG  = 0
17327       KSLOO  = 0
17328       KHLOO  = 0
17329       KSDPO  = 0
17330       KSOFT  = 0
17331       KHARD  = 0
17332 C
17333       IDNODF = 0
17334       IDIFR1 = 0
17335       IDIFR2 = 0
17336       IDDPOM = 0
17337       ISTR   = 0
17338       IPOIX1 = 0
17339       IF(ISWMDL(14).GT.0) IPOIX1 = 1
17340       IPOIX2 = 0
17341       IPOIX3 = 0
17342 C  reset /POEVT1/ and /POEVT2/
17343       CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17344      &            0,0,0,0,IPOS,0)
17345       CALL PHO_SELCOL(0,0,0,0,0,0,0)
17346       DO 15 I=0,10
17347         IPOWGC(I) = 0
17348  15   CONTINUE
17349
17350 C  initialization of particle kinematics
17351
17352 C  lepton-photon/hadron-photon vertex and initial particles
17353         IM(1) = 0
17354         IM(2) = 0
17355         IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17356           CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17357      &      PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17358         ELSE
17359           CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17360      &      P1(4),0,0,0,0,IP1,1)
17361         ENDIF
17362         IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17363           CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17364      &      PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17365         ELSE
17366           CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17367      &      P2(4),0,0,0,0,IP2,1)
17368         ENDIF
17369         IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17370           CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17371      &      PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17372           CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17373      &      P1(4),0,0,0,0,IP1,1)
17374         ENDIF
17375         IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17376           CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17377      &      PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17378           CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17379      &      P2(4),0,0,0,0,IP2,1)
17380         ENDIF
17381         NEVHEP = KACCEP
17382
17383       IF(IMODE.LE.1) THEN
17384 C  CMS energy
17385         ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17386      &           -(P1(3)+P2(3))**2)
17387 *       CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17388         PMASS(1) = PHEP(5,IP1)
17389         PVIRT(1) = 0.D0
17390         IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17391         PMASS(2) = PHEP(5,IP2)
17392         PVIRT(2) = 0.D0
17393         IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17394       ENDIF
17395
17396 C  cross section calculations
17397
17398       IF(IMODE.NE.1) THEN
17399         IP = 1
17400         CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17401      &              ECM,PVIRT(1),PVIRT(2))
17402       ENDIF
17403
17404       IF(IMODE.LE.0) THEN
17405 C  effective cross section
17406         SIGGEN(3) = 0.D0
17407         IF(ISWMDL(2).ge.1) THEN
17408           IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17409      &      -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17410      &      -SIGHDD-SIGDIR
17411           IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17412           IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17413           IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17414           IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17415           IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17416           IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17417           IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17418 C  simulate only hard scatterings
17419         ELSE
17420           IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17421           IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17422         ENDIF
17423
17424       ENDIF
17425
17426 C  reset of mother/daughter relations only (IMODE = 2)
17427
17428 C  debug output
17429       IF(IDEB(63).GE.15) THEN
17430         WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17431      &    '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17432         IF(IMODE.LE.0) THEN
17433           WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17434      &      'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17435      &      FSUP,FSUH,FSUD
17436           ONEM = -1.D0
17437           ITMP = IDEB(57)
17438           IDEB(57) = MAX(5,ITMP)
17439           CALL PHO_XSECT(1,0,ONEM)
17440           IDEB(57) = ITMP
17441         ENDIF
17442         CALL PHO_PREVNT(0)
17443       ENDIF
17444
17445       END
17446
17447 CDECK  ID>, PHO_CSINT
17448       SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17449 C********************************************************************
17450 C
17451 C     calculate cross sections by interpolation
17452 C
17453 C     input:   IP          particle combination
17454 C              IFPA/B      particle PDG number
17455 C              IHLA/B      particle helicity (photons only)
17456 C              ECM         c.m. energy (GeV)
17457 C              PVIR2A      virtuality of particle A (GeV**2, positive)
17458 C              PVIR2B      virtuality of particle B (GeV**2, positive)
17459 C
17460 C     output:  cross sections stored in /POCSEC/
17461 C
17462 C********************************************************************
17463       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17464       SAVE
17465
17466       PARAMETER ( EPS    =  1.D-5,
17467      &            DEPS   =  1.D-15 )
17468
17469 C  input/output channels
17470       INTEGER LI,LO
17471       COMMON /POINOU/ LI,LO
17472 C  some constants
17473       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17474       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17475      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17476 C  event debugging information
17477       INTEGER NMAXD
17478       PARAMETER (NMAXD=100)
17479       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17480      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17481       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17482      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17483 C  model switches and parameters
17484       CHARACTER*8 MDLNA
17485       INTEGER ISWMDL,IPAMDL
17486       DOUBLE PRECISION PARMDL
17487       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17488 C  energy-interpolation table
17489       INTEGER IEETA2
17490       PARAMETER ( IEETA2 = 20 )
17491       INTEGER ISIMAX
17492       DOUBLE PRECISION SIGTAB,SIGECM
17493       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17494 C  cross sections
17495       INTEGER IPFIL,IFAFIL,IFBFIL
17496       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17497      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17498      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17499      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17500      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17501       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17502      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17503      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17504      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17505      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17506      &                IPFIL,IFAFIL,IFBFIL
17507 C  hard cross sections and MC selection weights
17508       INTEGER Max_pro_2
17509       PARAMETER ( Max_pro_2 = 16 )
17510       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17511      &  MH_acc_1,MH_acc_2
17512       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17513       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17514      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17515      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17516      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17517      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17518
17519       DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17520
17521       dimension PD(-6:6),FH_T(2),FH_L(2)
17522
17523 C  debug
17524       IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17525      &  'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17526      &  IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17527
17528 C  check currently stored cross sections
17529       IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17530      &   .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17531      &   .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17532 C  nothing to calculate
17533         IF(IDEB(15).GE.20)
17534      &    WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17535         RETURN
17536       ELSE
17537
17538 C  copy to local fields
17539         IFPAP(1) = IFPA
17540         IFPAP(2) = IFPB
17541         IHEL(1)  = IHLA
17542         IHEL(2)  = IHLB
17543         PVIRT(1) = PVIR2A
17544         PVIRT(2) = PVIR2B
17545
17546 C  load cross sections from interpolation table
17547         IF(ECM.LE.SIGECM(IP,1)) THEN
17548           I1 = 1
17549           I2 = 2
17550         ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17551           DO 50 I=2,ISIMAX
17552             IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17553  50       CONTINUE
17554  200      CONTINUE
17555           I1 = I-1
17556           I2 = I
17557         ELSE
17558           WRITE(LO,'(/1X,A,2E12.3)')
17559      &      'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17560           CALL PHO_PREVNT(-1)
17561           I1 = ISIMAX-1
17562           I2 = ISIMAX
17563         ENDIF
17564         FAC2=0.D0
17565         IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17566      &                    /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17567         FAC1=1.D0-FAC2
17568
17569 C  cross section dependence on photon virtualities
17570         DO 140 K=1,2
17571           FSUP(K) = 1.D0
17572           FSUD(K) = 1.D0
17573           FSUH(K) = 1.D0
17574           IF(IFPAP(K).EQ.22) THEN
17575             IF(ISWMDL(10).GE.1) THEN
17576               FSUP(K) = 0.D0
17577               FSUT(K) = 0.D0
17578               FSUL(K) = 0.D0
17579               FSUH(K) = 0.D0
17580 C  GVDM factors for transverse/longitudinal photons
17581               DO 150 I=1,3
17582                 FSUT(K) = FSUT(K)+PARMDL(26+I)
17583      &                   /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17584                 FSUL(K) = FSUL(K)
17585      &                   +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17586      &                   /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17587  150          CONTINUE
17588               FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17589 C  transverse part
17590               IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17591                 FSUP(K) = FSUT(K)
17592                 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17593 C  diffraction of trans. photons corresponds mainly to leading twist
17594                 FSUD(K) = 1.D0
17595               ENDIF
17596 C  longitudinal (scalar) part
17597               IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17598                 FSUP(K) = FSUP(K)+FSUL(K)
17599                 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17600 C  diffraction of long. photons corresponds mainly to higher twist
17601                 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17602      &                   /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17603      &                   /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17604               ENDIF
17605 C  debug output
17606               if(ideb(15).ge.10) then
17607                 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17608      &            'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17609      &            K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17610               endif
17611             ENDIF
17612           ENDIF
17613  140    CONTINUE
17614
17615         FACP = FSUP(1)*FSUP(2)
17616         FACH = FSUH(1)*FSUH(2)
17617         FACD = FSUD(1)*FSUD(2)
17618
17619 C  matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17620
17621         if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17622      &     .and.(IPAMDL(117).gt.0)) then
17623 C  check kinematic limit
17624           Q2_max = max(PVIRT(1),PVIRT(2))
17625           Q2_min = min(PVIRT(1),PVIRT(2))
17626           if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17627
17628 C  calculate F2 from current parton density
17629             if(PVIRT(1).gt.PVIRT(2)) then
17630               K = 2
17631             else
17632               K = 1
17633             endif
17634             Q2 = Q2_max
17635             P2 = Q2_min
17636             X = Q2/(ECM**2+Q2+P2)
17637             call pho_actpdf(IFPAP(K),K)
17638             call pho_pdf(K,X,Q2,P2,PD)
17639 C  light quark contribution
17640             F2_light = 0.D0
17641             do j=1,3
17642               F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17643             enddo
17644 C  heavy quark contribution
17645             call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17646             F2_c = 2.D0*4.D0/9.D0*xpdf_c
17647             F2 = (F2_light+F2_c)
17648
17649 C  calculate model prediction
17650             SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17651             SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17652             CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17653
17654             if(ISWMDL(10).ge.2) then
17655
17656 C  calculate all helicity combinations
17657               if(IPAMDL(115).eq.0) then
17658                 SIGDIH    = HSig(14)
17659                 SIGSRH(1) = HSig(10)+HSig(11)
17660                 SIGSRH(2) = HSig(12)+HSig(13)
17661                 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17662 C  photon helicity factors
17663                 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17664                 FH_L(1) = 1.D0-FH_T(1)
17665                 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17666                 FH_L(2) = 1.D0-FH_T(2)
17667                 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17668      &                  + SIGDIH*FH_T(1)*FH_T(2)
17669      &                  + SIGSRH(1)*FH_T(1)*FSUT(2)
17670      &                  + SIGSRH(2)*FSUT(1)*FH_T(2)
17671                 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17672      &                  + SIGDIH*FH_T(1)*FH_L(2)
17673      &                  + SIGSRH(1)*FH_T(1)*FSUL(2)
17674      &                  + SIGSRH(2)*FSUT(1)*FH_L(2)
17675                 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17676      &                  + SIGDIH*FH_L(1)*FH_T(2)
17677      &                  + SIGSRH(1)*FH_L(1)*FSUT(2)
17678      &                  + SIGSRH(2)*FSUL(1)*FH_T(2)
17679                 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17680      &                  + SIGDIH*FH_L(1)*FH_L(2)
17681      &                  + SIGSRH(1)*FH_L(1)*FSUL(2)
17682      &                  + SIGSRH(2)*FSUL(1)*FH_L(2)
17683               else
17684 C  use explicit PDF virtuality dependence (pre-tabulated)
17685                 SIGDIH    = HSig(14)
17686                 SIGSRH(1) = HSig(10)+HSig(11)
17687                 SIGSRH(2) = HSig(12)+HSig(13)
17688                 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17689                 print LO,' PHO_CSINT: invalid option for F2 matching'
17690                 stop
17691 *               CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17692 *    &                          Max_pro_2,3,4,1)
17693 *               SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17694 *    &                  + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17695 *               SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17696 *    &                  + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17697 *               SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17698 *    &                  + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17699 *               SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17700 *    &                  + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17701               endif
17702               Xnu = Ecm*Ecm+Q2+P2
17703               F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17704      &             *137.D0/GeV2mb
17705               if(K.eq.2) then
17706                 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17707                 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17708      &               -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17709               else
17710                 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17711                 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17712      &               -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17713               endif
17714
17715             else
17716
17717 C  assume sig_eff = sigtot
17718               SIGDIH    = HSig(14)
17719               SIGSRH(1) = HSig(10)+HSig(11)
17720               SIGSRH(2) = HSig(12)+HSig(13)
17721               SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17722               SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17723      &                +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17724               Xnu = Ecm*Ecm+Q2+P2
17725               F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17726      &             *137.D0/GeV2mb
17727               F2m = F2_fac*SIGeff
17728               F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17729             endif
17730 *           print LO,' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17731 *           print LO,' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
17732
17733 C  global factor to re-scale suppression of soft contributions
17734             Fcorr = (F2-F2m+F2s)/F2s
17735 *           print LO,' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
17736             FACP = FACP*Fcorr
17737
17738           endif
17739         endif
17740
17741         SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17742         SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17743         SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17744         J = 2
17745         DO 5 I=0,4
17746           DO 6 K=0,4
17747             J = J+1
17748             SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17749      &                  *FACP**2
17750  6        CONTINUE
17751  5      CONTINUE
17752
17753         SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17754         SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17755 C  suppression of multi-pomeron graphs (diffraction)
17756         SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17757      &             *FACP*FSUP(2)*FSUD(1)
17758         SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17759      &             *FACP*FSUP(1)*FSUD(2)
17760         SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17761      &             *FACP*FSUP(2)*FSUD(1)
17762         SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17763      &             *FACP*FSUP(1)*FSUD(2)
17764         SIGLDD    = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17765      &             *FACP**2*FACD
17766         SIGHDD    = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17767         SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17768      &             *FACP**2
17769         SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17770      &             *FACP*FSUP(2)*FSUD(1)
17771         SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17772      &             *FACP*FSUP(2)*FSUD(1)
17773         SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17774      &             *FACP*FSUP(1)*FSUD(2)
17775         SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17776      &             *FACP*FSUP(1)*FSUD(2)
17777         SIGLOO    = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17778         SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17779      &             *FACP**2
17780         SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17781      &             *FACP**2
17782         SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17783      &             *FACP**2
17784         SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17785      &             *FACP**2
17786
17787 C  corrections due to photon virtuality dependence of PDFs
17788         if(iswmdl(2).eq.1) then
17789           CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17790 C  minimum bias event generation
17791           IF(IPAMDL(115).GE.1) THEN
17792 C  all the virtuality dependence is given by PDF parametrization
17793             SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17794             IF(IPAMDL(116).GE.2) THEN
17795 C  direct interaction according to full QPM calculation
17796               SIGDIH = HSig(14)
17797               SIGSRH(1) = HSig(10)+HSig(11)
17798               SIGSRH(2) = HSig(12)+HSig(13)
17799             ELSE
17800 C  direct interaction suppressed according to helicity factor
17801               SIGDIH = HSig(14)*FACH
17802               SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17803               SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17804             ENDIF
17805             print LO,' PHO_CSINT: option not supported yet'
17806             stop
17807           ELSE
17808 C  rescale relevant hard processes
17809             SIGDIH    = HSig(14)
17810             SIGSRH(1) = HSig(10)+HSig(11)
17811             SIGSRH(2) = HSig(12)+HSig(13)
17812             SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17813             SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17814      &              +SIGSRH(2)*FSUP(1)*FSUH(2)
17815             SIGINE = SIGtmp+SIGDIR
17816             SIGTOT = SIGINE+SIGELA
17817           ENDIF
17818         else
17819 C  only hard interactions
17820           CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17821           SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17822           SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17823           SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17824           SIGHAR = HSig(9)*FACH
17825         endif
17826
17827         SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17828         SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17829         SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17830         J = 39
17831         DO 9 I=1,4
17832           DO 10 K=1,4
17833             J = J+1
17834             SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17835  10       CONTINUE
17836  9      CONTINUE
17837         SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17838         SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17839
17840         IPFIL  = IP
17841         IFAFIL = IFPA
17842         IFBFIL = IFPB
17843         ECMFIL = ECM
17844         P2AFIL = PVIR2A
17845         P2BFIL = PVIR2B
17846
17847         IF(IDEB(15).GE.20)
17848      &    WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17849
17850       ENDIF
17851
17852       END
17853
17854 CDECK  ID>, PHO_PRIMKT
17855       SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17856 C***********************************************************************
17857 C
17858 C    give primordial kt to partons entering hard scatterings and
17859 C    remants connected to hard parton-parton interactions by color flow
17860 C
17861 C    input:  IMODE   -2   output of statistics
17862 C                    -1   initialization
17863 C                     1   sampling of primordial kt
17864 C            IF           first entry in /POEVT1/ to check
17865 C            IL           last entry in /POEVT1/ to check
17866 C            PTCUT        current value of PTCUT to distinguish
17867 C                         between soft and hard
17868 C
17869 C    output: IREJ     0   success
17870 C                     1   failure
17871 C
17872 C***********************************************************************
17873
17874       IMPLICIT NONE
17875
17876       SAVE
17877
17878       DOUBLE PRECISION DEPS
17879       PARAMETER ( DEPS = 1.D-15 )
17880
17881       INTEGER IMODE,IF,IL,IREJ
17882       DOUBLE PRECISION PTCUT
17883
17884 C  input/output channels
17885       INTEGER LI,LO
17886       COMMON /POINOU/ LI,LO
17887 C  event debugging information
17888       INTEGER NMAXD
17889       PARAMETER (NMAXD=100)
17890       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17891      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17892       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17893      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17894 C  model switches and parameters
17895       CHARACTER*8 MDLNA
17896       INTEGER ISWMDL,IPAMDL
17897       DOUBLE PRECISION PARMDL
17898       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17899 C  some constants
17900       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17901       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17902      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17903 C  data of c.m. system of Pomeron / Reggeon exchange
17904       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
17905       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
17906      &                 SIDP,CODP,SIFP,COFP
17907       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
17908      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
17909      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
17910 C  hard scattering data
17911       INTEGER MSCAHD
17912       PARAMETER ( MSCAHD = 50 )
17913       INTEGER LSCAHD,LSC1HD,LSIDX,
17914      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
17915       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
17916       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
17917      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
17918      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
17919      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
17920      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
17921      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
17922      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
17923
17924 C  standard particle data interface
17925       INTEGER NMXHEP
17926
17927       PARAMETER (NMXHEP=4000)
17928
17929       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17930       DOUBLE PRECISION PHEP,VHEP
17931       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17932      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17933      &                VHEP(4,NMXHEP)
17934 C  extension to standard particle data interface (PHOJET specific)
17935       INTEGER IMPART,IPHIST,ICOLOR
17936       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17937
17938       DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
17939       DIMENSION PTS(0:2,5),XP(5),
17940      &  XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
17941
17942       INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
17943
17944       PARAMETER (IRMAX=200)
17945       DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
17946
17947       DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
17948      &                 DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
17949       INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
17950
17951 C  debug output
17952       IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
17953      &  'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
17954      &  IMODE,IF,IL,PTCUT
17955
17956 C  give primordial kt to partons engaged in a hard scattering
17957
17958       IF(IMODE.EQ.1) THEN
17959
17960         ISTART = IF
17961
17962  100    CONTINUE
17963
17964         NHD = 0
17965         IBAL(1) = 0
17966         IBAL(2) = 0
17967         IROT = 0
17968         ICOM = 0
17969         DO 110 I=ISTART,IL
17970           IF(ISTHEP(I).EQ.25) THEN
17971 C  hard scattering number
17972             NHD = IPHIST(1,I+1)
17973             ICOM = I
17974             K = LSIDX(NHD/100)
17975 C  calculate momenta of incoming partons
17976             POLD(1,1) = XHD(K,1)*ECMP/2.D0
17977             POLD(2,1) = POLD(1,1)
17978             POLD(1,2) = -XHD(K,2)*ECMP/2.D0
17979             POLD(2,2) = -POLD(1,2)
17980             ISTART = I+3
17981             GOTO 150
17982           ENDIF
17983  110    CONTINUE
17984         RETURN
17985
17986  150    CONTINUE
17987
17988 C  search for partons involved in hard interaction
17989         INEXT = 0
17990         IROT = 0
17991         DO 500 I=ISTART,IL
17992           IF(ABS(ISTHEP(I)).EQ.1) THEN
17993 C  hard scatterd partons (including ISR)
17994             IF((IPHIST(1,I).EQ.-NHD)
17995      &         .OR.(IPHIST(1,I).EQ.NHD+1)
17996      &         .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
17997               IROT = IROT+1
17998
17999               IF(IROT.GT.IRMAX) THEN
18000                 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
18001      &            'no memory left in IROTT, event rejected (max/IROT)',
18002      &            IRMAX,IROT
18003                 CALL PHO_PREVNT(0)
18004                 IREJ = 1
18005                 RETURN
18006               ENDIF
18007
18008               IROTT(IROT) = I
18009 C  hard remnant
18010             ELSE IF(IPHIST(1,I).EQ.NHD) THEN
18011               IF(PHEP(3,I).GT.0.D0) THEN
18012                 J = 1
18013               ELSE
18014                 J = 2
18015               ENDIF
18016               IBAL(J) = IBAL(J)+1
18017               IBALT(IBAL(J),J) = I
18018               XP2(IBAL(J),J) = PHEP(3,I)/ECMP
18019               IF(ISWMDL(24).EQ.0) THEN
18020                 IV2(IBAL(J),J) = 0
18021                 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
18022               ELSE IF(ISWMDL(24).EQ.1) THEN
18023                 IV2(IBAL(J),J) = -1
18024               ELSE
18025                 IV2(IBAL(J),J) = 1
18026               ENDIF
18027             ENDIF
18028 C  possibly further hard scattering
18029           ELSE IF(ISTHEP(I).EQ.25) THEN
18030             INEXT = 1
18031             ISTART = I
18032             GOTO 550
18033           ENDIF
18034  500    CONTINUE
18035  550    CONTINUE
18036
18037 C debug output
18038         if(IDEB(10).ge.15) then
18039           WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
18040      &      'hard scattering number: ',NHD/100
18041           WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
18042      &      'number of entries to rotate: ',IROT
18043           DO I=1,IROT
18044             WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
18045      &        'entries to rotate: ',I,IROTT(I)
18046           ENDDO
18047           WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
18048      &      'number of entries to balance: ',IBAL
18049           DO J=1,2
18050             DO I=1,IBAL(J)
18051               WRITE(LO,'(1X,2A,I2,2I5)')
18052      &          'PHO_PRIMKT: entries to balance (side,no,line)',
18053      &          J,I,IBALT(I,J)
18054             ENDDO
18055           ENDDO
18056         endif
18057
18058 C  incoming partons (comment lines), skip direct interacting particles
18059         DO 120 K=1,2
18060           IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
18061             IF(PHEP(3,ICOM+K).GT.0.D0) THEN
18062               J = 1
18063             ELSE
18064               J = 2
18065             ENDIF
18066             IBAL(J) = IBAL(J)+1
18067             IBALT(IBAL(J),J) = -ICOM-K
18068             XP2(IBAL(J),J) = POLD(1,J)/ECMP
18069             IV2(IBAL(J),J) = -1
18070           ENDIF
18071  120    CONTINUE
18072
18073 C  check consistency
18074         IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18075           WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18076      &      'inconsistent hard scattering remnant for event: ',KEVENT
18077           WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18078      &      'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18079      &      IMODE,IF,IL,PTCUT
18080           WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18081           DO 390 I=1,IROT
18082             WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18083  390      CONTINUE
18084           DO 392 J=1,2
18085             DO 395 I=1,IBAL(J)
18086               WRITE(LO,'(1X,A,I2,2I5)')
18087      &          'entries to balance (side,no,line)',J,I,IBALT(I,J)
18088  395        CONTINUE
18089  392      CONTINUE
18090           IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18091         ENDIF
18092
18093 C  calculate primordial kt
18094
18095 C  something to do?
18096         IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18097
18098 C  add transverse momentum (overwrite /POEVT1/ entries)
18099         DO 200 J=1,2
18100           IF(IBAL(J).GT.1) THEN
18101 C  sample from truncated distribution
18102             K = IBAL(J)
18103             DO 180 I=1,K
18104               IV(I) = IV2(I,J)
18105               XP(I) = XP2(I,J)
18106  180        CONTINUE
18107  190        CONTINUE
18108               CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18109             IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18110 C  transform incoming partons of hard scattering
18111             DEL = ABS(POLD(1,J))+POLD(2,J)
18112             PT2 = PTS(0,K)**2
18113             DEL2 = DEL*DEL
18114             PNEW(1,J) = PTS(1,K)
18115             PNEW(2,J) = PTS(2,K)
18116             PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18117             PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18118 C  spectator partons
18119             ESUM = 0.D0
18120             DO 220 I=1,IBAL(J)-1
18121               K = IBALT(I,J)
18122               PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18123               PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18124               ESUM = ESUM+PHEP(4,K)
18125  220        CONTINUE
18126 C  long. momentum transfer
18127             PP(3) = PNEW(3,J) - POLD(1,J)
18128             PP(4) = PNEW(4,J) - POLD(2,J)
18129             DO 230 I=1,IBAL(J)-1
18130               K = IBALT(I,J)
18131               FAC = PHEP(4,K)/ESUM
18132               PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18133               PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18134  230        CONTINUE
18135
18136 C  debug output
18137             IF(IDEB(10).GE.15) THEN
18138               WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18139      &          'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18140               WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18141      &          'new incoming:',J,(PNEW(I,J),I=1,4)
18142             ENDIF
18143
18144           ELSE
18145             PNEW(1,J) = 0.D0
18146             PNEW(2,J) = 0.D0
18147             PNEW(3,J) = POLD(1,J)
18148             PNEW(4,J) = POLD(2,J)
18149           ENDIF
18150  200    CONTINUE
18151
18152 C  transformation of hard scattering final states (including ISR)
18153
18154 C  old parton c.m. energy
18155         SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18156         EI = SQRT(SI)
18157 C  new parton c.m. energy
18158         SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18159      &       -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18160         EF = SQRT(SF)
18161         FAC = EF/EI
18162 C  debug output
18163         IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18164      &    'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18165
18166 C  calculate Lorentz transformation
18167         GAZ = -(POLD(1,1)+POLD(1,2))/EI
18168         GAE = (POLD(2,1)+POLD(2,2))/EI
18169         DO 240 I=1,4
18170           GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18171  240    CONTINUE
18172         CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18173      &    PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18174         PTOT = MAX(DEPS,PTOT)
18175         COD= PP(3)/PTOT
18176         SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18177         COF= 1.D0
18178         SIF= 0.D0
18179         IF(PTOT*SID.GT.1.D-5) THEN
18180           COF=PP(1)/(SID*PTOT)
18181           SIF=PP(2)/(SID*PTOT)
18182           ANORF=SQRT(COF*COF+SIF*SIF)
18183           COF=COF/ANORF
18184           SIF=SIF/ANORF
18185         ENDIF
18186
18187 C  debug output
18188 C  check consistency initial/final configuration before rotation
18189         IF(IDEB(10).GE.25) THEN
18190           WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18191      &      0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18192           DO I=1,4
18193             PP(I) = 0.D0
18194           ENDDO
18195           DO I=1,IROT
18196             K = IROTT(I)
18197             DO J=1,4
18198               PP(J) = PP(J)+PHEP(J,K)
18199             ENDDO
18200           ENDDO
18201           WRITE(LO,'(1X,A,1P,4E11.3)')
18202      &      'PHO_PRIMKT: fin. momentum (1):',PP
18203         ENDIF
18204
18205 C  apply rotation/boost to scattered particles
18206         DO 400 I=1,IROT
18207           K = IROTT(I)
18208           DO 350 J=1,4
18209             PP(J) = FAC*PHEP(J,K)
18210  350      CONTINUE
18211           CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18212      &      PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18213           CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18214      &      COD,SID,COF,SIF,XX,YY,ZZ)
18215           EE = PHEP(4,K)
18216           CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18217      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18218  400    CONTINUE
18219
18220 C  debug output
18221 C  check consistency initial/final configuration after rotation
18222         IF(IDEB(10).GE.25) THEN
18223           DO I=1,4
18224             PP(I) = PNEW(I,1)+PNEW(I,2)
18225           ENDDO
18226           WRITE(LO,'(1X,A,1P,4E11.3)')
18227      &      'PHO_PRIMKT: ini. momentum (2):',PP
18228           DO I=1,4
18229             PP(I) = 0.D0
18230           ENDDO
18231           DO I=1,IROT
18232             K = IROTT(I)
18233             DO J=1,4
18234               PP(J) = PP(J)+PHEP(J,K)
18235             ENDDO
18236           ENDDO
18237           WRITE(LO,'(1X,A,1P,4E11.3)')
18238      &      'PHO_PRIMKT: fin. momentum (2):',PP
18239         ENDIF
18240
18241         ENDIF
18242
18243         IF(INEXT.EQ.1) GOTO 100
18244
18245 C  initialization
18246
18247       ELSE IF(IMODE.EQ.-1) THEN
18248
18249 C  output of statistics etc.
18250
18251       ELSE IF(IMODE.EQ.-2) THEN
18252
18253 C  something wrong
18254
18255       ELSE
18256         WRITE(LO,'(/1X,A,I4)')
18257      &    'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18258         CALL PHO_ABORT
18259       ENDIF
18260
18261       END
18262
18263 CDECK  ID>, PHO_PARTPT
18264       SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18265 C********************************************************************
18266 C
18267 C    assign to soft partons
18268 C
18269 C    input:  IMODE   -2   output of statistics
18270 C                    -1   initialization
18271 C                     0   sampling of pt for soft partons belonging to
18272 C                         soft Pomerons
18273 C                     1   sampling of pt for soft partons belonging to
18274 C                         hard Pomerons
18275 C            IF           first entry in /POEVT1/ to check
18276 C            IL           last entry in /POEVT1/ to check
18277 C            PTCUT        current value of PTCUT to distinguish
18278 C                         between soft and hard
18279 C
18280 C    output: IREJ     0   success
18281 C                     1   failure
18282 C
18283 C    (soft pt is sampled by call to PHO_SOFTPT)
18284 C
18285 C********************************************************************
18286       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18287       SAVE
18288
18289       PARAMETER ( DEPS = 1.D-15 )
18290
18291       INTEGER IMODE,IF,IL,IREJ
18292       DOUBLE PRECISION PTCUT
18293
18294 C  input/output channels
18295       INTEGER LI,LO
18296       COMMON /POINOU/ LI,LO
18297 C  event debugging information
18298       INTEGER NMAXD
18299       PARAMETER (NMAXD=100)
18300       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18301      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18302       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18303      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18304 C  model switches and parameters
18305       CHARACTER*8 MDLNA
18306       INTEGER ISWMDL,IPAMDL
18307       DOUBLE PRECISION PARMDL
18308       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18309 C  some constants
18310       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18311       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18312      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18313 C  data of c.m. system of Pomeron / Reggeon exchange
18314       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18315       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18316      &                 SIDP,CODP,SIFP,COFP
18317       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18318      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18319      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18320
18321 C  standard particle data interface
18322       INTEGER NMXHEP
18323
18324       PARAMETER (NMXHEP=4000)
18325
18326       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18327       DOUBLE PRECISION PHEP,VHEP
18328       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18329      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18330      &                VHEP(4,NMXHEP)
18331 C  extension to standard particle data interface (PHOJET specific)
18332       INTEGER IMPART,IPHIST,ICOLOR
18333       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18334
18335       DOUBLE PRECISION PTS,PB,XP,XPB,PC
18336       DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18337
18338       INTEGER MODIFY,IV,IVB
18339       DIMENSION MODIFY(50),IV(50),IVB(2)
18340
18341 C  debug output
18342       IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18343      &  'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18344      &  IMODE,IF,IL,PTCUT
18345
18346       IF(IMODE.LT.0) GOTO 1000
18347
18348       IREJ = 0
18349       IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18350
18351 C  count entries to modify
18352       IENTRY = 0
18353       PTCUT2 = PTCUT**2
18354       EMIN = 1.D20
18355       IPEAK = 1
18356       ISTART = IF
18357
18358 C  soft Pomerons
18359
18360       IF(IMODE.EQ.0) THEN
18361         DO 300 I=ISTART,IL
18362           IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18363             IENTRY = IENTRY+1
18364             MODIFY(IENTRY) = I
18365             XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18366             IV(IENTRY) = 0
18367             IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18368             IF(PHEP(4,I).LT.EMIN) THEN
18369               EMIN = PHEP(4,I)
18370               IPEAK = IENTRY
18371             ENDIF
18372           ENDIF
18373  300    CONTINUE
18374
18375 C  hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18376
18377       ELSE IF(IMODE.EQ.1) THEN
18378
18379         DO 350 I=ISTART,IL
18380           IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18381             IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18382               IENTRY = IENTRY+1
18383               MODIFY(IENTRY) = I
18384               XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18385               IF(ISWMDL(24).EQ.0) THEN
18386                 IV(IENTRY) = 0
18387                 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18388               ELSE IF(ISWMDL(24).EQ.1) THEN
18389                 IV(IENTRY) = -1
18390               ELSE
18391                 IV(IENTRY) = 1
18392               ENDIF
18393               IF(PHEP(4,I).LT.EMIN) THEN
18394                 EMIN = PHEP(4,I)
18395                 IPEAK = IENTRY
18396               ENDIF
18397             ENDIF
18398           ENDIF
18399  350    CONTINUE
18400
18401 C  something wrong
18402
18403       ELSE
18404         WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18405         CALL PHO_ABORT
18406       ENDIF
18407
18408 C  debug output
18409       IF(IDEB(6).GE.5) THEN
18410         WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18411      &    'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18412         IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18413       ENDIF
18414
18415 C  nothing to do
18416       IF(IENTRY.LE.1) RETURN
18417
18418 C  sample pt of soft partons
18419
18420       IF(ISWMDL(5).LE.1) THEN
18421         ITER = 0
18422         IPEAK = DT_RNDM(DUM)*IENTRY+1
18423         CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18424         CALL PHO_SWAPD(XP(IPEAK),XP(1))
18425         CALL PHO_SWAPI(IV(IPEAK),IV(1))
18426  400    CONTINUE
18427 C  energy limited sampling
18428           PSUMX = 0.D0
18429           PSUMY = 0.D0
18430           ITER = ITER+1
18431           IF(ITER.GE.1000) THEN
18432             IF(IDEB(6).GE.3) THEN
18433               WRITE(LO,'(1X,A,3I5)')
18434      &          'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18435      &          IMODE,IENTRY,ITER
18436               WRITE(LO,'(8X,A,I5)') 'I  II  IV       XP         EP',
18437      &          IPEAK
18438               DO 405 I=1,IENTRY
18439                 II = MODIFY(I)
18440                 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18441      &            I,II,IV(I),XP(I),PHEP(4,II)
18442  405          CONTINUE
18443               IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18444             ENDIF
18445             IREJ = 1
18446             RETURN
18447           ENDIF
18448           DO 410 I=2,IENTRY
18449             II = MODIFY(I)
18450             PTMX = MIN(PHEP(4,II),PTCUT)
18451             XPB(1) = XP(I)
18452             IVB(1) = IV(I)
18453             IF(ISWMDL(5).EQ.0) THEN
18454               CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18455             ELSE
18456               CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18457             ENDIF
18458             PTS(0,I) = PB(0,1)
18459             PTS(1,I) = PB(1,1)
18460             PTS(2,I) = PB(2,1)
18461             PSUMX = PSUMX+PB(1,1)
18462             PSUMY = PSUMY+PB(2,1)
18463  410      CONTINUE
18464           PTREM = SQRT(PSUMX**2+PSUMY**2)
18465         IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18466         PTS(1,1) = -PSUMX
18467         PTS(2,1) = -PSUMY
18468       ELSE IF((ISWMDL(5).EQ.2)
18469      &        .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18470 C  unlimited sampling
18471         IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18472         CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18473         CALL PHO_SWAPD(XP(IPEAK),XP(1))
18474         CALL PHO_SWAPI(IV(IPEAK),IV(1))
18475         CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18476       ELSE IF(ISWMDL(5).EQ.3) THEN
18477 C  each string has balanced pt
18478         DO 500 K=1,IENTRY
18479           IF(IV(K).LE.-90) GOTO 499
18480           I1 = MODIFY(K)
18481           IC1 = -ICOLOR(1,I1)
18482           DO 510 L=K+1,IENTRY
18483             IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18484  510      CONTINUE
18485           WRITE(LO,'(//1X,A,I5)')
18486      &      'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18487           CALL PHO_ABORT
18488  511      CONTINUE
18489           I2 = MODIFY(L)
18490           AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18491      &           -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18492           AM   = SQRT(AMSQR)
18493           PTMX = AM/2.D0
18494           IVB(1) = MAX(IV(K),IV(L))
18495           XPB(1) = XP(K)
18496           CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18497           PTS(1,K) = PB(1,1)
18498           PTS(2,K) = PB(2,1)
18499           PTS(1,L) = -PB(1,1)
18500           PTS(2,L) = -PB(2,1)
18501           GAM    = (PHEP(4,I1)+PHEP(4,I2))/AM
18502           GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18503           PC(1) = PB(1,1)
18504           PC(2) = PB(2,1)
18505           PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18506           PC(3) = SIGN(PLONG,PHEP(3,I1))
18507           PC(4) = PTMX
18508           CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18509      &               PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18510           PC(1) = -PC(1)
18511           PC(2) = -PC(2)
18512           PC(3) = -PC(3)
18513           CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18514      &               PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18515           IV(K) = IV(K)-100
18516           IV(L) = IV(L)-100
18517  499      CONTINUE
18518  500    CONTINUE
18519       ELSE
18520         WRITE(LO,'(/1X,A,I4)')
18521      &    'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18522         CALL PHO_ABORT
18523       ENDIF
18524
18525 C  change partons in /POEVT1/
18526       DO 900 II=1,IENTRY
18527         IF(IV(II).GT.-90) THEN
18528           I = MODIFY(II)
18529           PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18530           PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18531           AMSQR = PHEP(4,I)**2
18532      &             -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18533           PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18534         ENDIF
18535  900  CONTINUE
18536
18537 C  debug output
18538       IF(IDEB(6).GE.15) THEN
18539         WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18540      &    'I  II  IV    XP    EP    PTS   PTX   PTY',IPEAK
18541         DO 505 I=1,IENTRY
18542           II = MODIFY(I)
18543           WRITE(LO,'(2X,3I5,1P,5E12.4)')
18544      &      I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18545  505    CONTINUE
18546         CALL PHO_PREVNT(0)
18547       ENDIF
18548       RETURN
18549
18550 C  initialization / output of statistics
18551  1000 CONTINUE
18552       CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18553
18554       END
18555
18556 CDECK  ID>, PHO_SOFTPT
18557       SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18558 C***********************************************************************
18559 C
18560 C    select pt of soft string ends
18561 C
18562 C    input:    ISOFT          number of soft partons
18563 C                    -1       initialization
18564 C                    >=0      sampling of p_t
18565 C                    -2       output of statistics
18566 C              PTCUT          cutoff for soft strings
18567 C              PTMAX          maximal allowed PT
18568 C              XV             field of x values
18569 C              IV             0    sea quark
18570 C                             1    valence quark
18571 C
18572 C    output:   /POINT3/       containing parameters AAS,BETAS
18573 C              PTSOF          filed with soft pt values
18574 C
18575 C    note:     ISWMDL(3/4) = 0  dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18576 C              ISWMDL(3/4) = 1  dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18577 C              ISWMDL(3/4) = 2  photon wave function
18578 C              ISWMDL(3/4) = 10 no soft P_t assignment
18579 C
18580 C***********************************************************************
18581       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18582       SAVE
18583
18584       PARAMETER ( DEPS   =  1.D-15)
18585
18586       DIMENSION PTSOF(0:2,*),XV(*)
18587       DIMENSION IV(*)
18588
18589 C  input/output channels
18590       INTEGER LI,LO
18591       COMMON /POINOU/ LI,LO
18592 C  event debugging information
18593       INTEGER NMAXD
18594       PARAMETER (NMAXD=100)
18595       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18596      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18597       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18598      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18599 C  model switches and parameters
18600       CHARACTER*8 MDLNA
18601       INTEGER ISWMDL,IPAMDL
18602       DOUBLE PRECISION PARMDL
18603       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18604 C  data of c.m. system of Pomeron / Reggeon exchange
18605       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18606       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18607      &                 SIDP,CODP,SIFP,COFP
18608       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18609      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18610      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18611 C  data on most recent hard scattering
18612       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18613       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18614      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18615      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18616       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18617      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18618      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18619      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18620      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18621 C  data needed for soft-pt calculation
18622       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18623       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18624
18625       DIMENSION BETAB(100)
18626
18627 C  selection of pt
18628       IF(ISOFT.GE.0) THEN
18629         CALLS = CALLS + 1.D0
18630 C  sample according to model ISWMDL(3-6)
18631         IF(ISOFT.GT.1) THEN
18632  210      CONTINUE
18633           PTXS = 0.D0
18634           PTYS = 0.D0
18635           DO 300 I=2,ISOFT
18636             IMODE = ISWMDL(3)
18637 C  valence partons
18638             IF(IV(I).EQ.1) THEN
18639               BETA = BETAS(1)
18640 C  photon/pomeron valence part
18641               IF(IPAMDL(5).EQ.1) THEN
18642                 IF(XV(I).GE.0.D0) THEN
18643                   IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18644                     IMODE = ISWMDL(4)
18645                     BETA = BETAS(3)
18646                   ENDIF
18647                 ELSE
18648                   IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18649                     IMODE = ISWMDL(4)
18650                     BETA = BETAS(3)
18651                   ENDIF
18652                 ENDIF
18653               ELSE IF(IPAMDL(5).EQ.2) THEN
18654                 BETA = PARMDL(20)
18655               ELSE IF(IPAMDL(5).EQ.3) THEN
18656                 BETA = BETAS(3)
18657               ENDIF
18658 C  sea partons
18659             ELSE IF(IV(I).EQ.0) THEN
18660               BETA = BETAS(3)
18661 C  hard scattering remnant
18662             ELSE
18663               IF(IPAMDL(6).EQ.0) THEN
18664                 BETA = BETAS(1)
18665               ELSE IF(IPAMDL(6).EQ.1) THEN
18666                 BETA = BETAS(3)
18667               ELSE
18668                 BETA = PARMDL(20)
18669               ENDIF
18670             ENDIF
18671             BETA = MAX(BETA,0.01D0)
18672             CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18673             PTS = MIN(PTMAX,PTS)
18674             CALL PHO_SFECFE(SIG,COG)
18675             PTSOF(0,I) = PTS
18676             PTSOF(1,I) = COG*PTS
18677             PTSOF(2,I) = SIG*PTS
18678             PTXS = PTXS+PTSOF(1,I)
18679             PTYS = PTYS+PTSOF(2,I)
18680             BETAB(I) = BETA
18681  300      CONTINUE
18682 C  balancing of momenta
18683           PTS = SQRT(PTXS**2+PTYS**2)
18684           IF(PTS.GE.PTMAX) GOTO 210
18685           PTSOF(0,1) = PTS
18686           PTSOF(1,1) = -PTXS
18687           PTSOF(2,1) = -PTYS
18688           BETAB(1) = 0.D0
18689 C
18690 *400      CONTINUE
18691 C
18692 C  single parton only
18693         ELSE
18694           IMODE = ISWMDL(3)
18695 C  valence partons
18696           IF(IV(1).EQ.1) THEN
18697             BETA = BETAS(1)
18698 C  photon/Pomeron valence part
18699             IF(IPAMDL(5).EQ.1) THEN
18700               IF(XV(1).GE.0.D0) THEN
18701                 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18702                   IMODE = ISWMDL(4)
18703                   BETA = BETAS(3)
18704                 ENDIF
18705               ELSE
18706                 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18707                   IMODE = ISWMDL(4)
18708                   BETA = BETAS(3)
18709                 ENDIF
18710               ENDIF
18711             ELSE IF(IPAMDL(5).EQ.2) THEN
18712               BETA = PARMDL(20)
18713             ELSE IF(IPAMDL(5).EQ.3) THEN
18714               BETA = BETAS(3)
18715             ENDIF
18716 C  sea partons
18717           ELSE IF(IV(1).EQ.0) THEN
18718             BETA = BETAS(3)
18719 C  hard scattering remnant
18720           ELSE
18721             IF(IPAMDL(6).EQ.1) THEN
18722               BETA = BETAS(3)
18723             ELSE
18724               BETA = PARMDL(20)
18725             ENDIF
18726           ENDIF
18727           BETA = MAX(BETA,0.01D0)
18728           CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18729           PTS = MIN(PTMAX,PTS)
18730           CALL PHO_SFECFE(SIG,COG)
18731           PTSOF(0,1) = PTS
18732           PTSOF(1,1) = COG*PTS
18733           PTSOF(2,1) = SIG*PTS
18734           BETAB(1) = BETA
18735         ENDIF
18736
18737 C  debug output
18738         IF(IDEB(29).GE.10) THEN
18739           WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18740           WRITE(LO,'(6X,A)') 'TABLE OF  I, IV, XV, PT, PT-X, PT-Y, BETA'
18741           DO 105 I=1,ISOFT
18742             WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18743      &        PTSOF(1,I),PTSOF(2,I),BETAB(I)
18744  105      CONTINUE
18745         ENDIF
18746
18747 C  initialization of statistics and parameters
18748
18749       ELSE IF(ISOFT.EQ.-1) THEN
18750         PTSMIN = 0.D0
18751         PTSMAX = PTCUT
18752
18753         IMODE = -100+ISWMDL(3)
18754         CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18755
18756 C  output of statistics
18757
18758       ELSE IF(ISOFT.EQ.-2) THEN
18759
18760       ELSE
18761         WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18762      &    'unsupported ISOFT ',ISOFT
18763         STOP
18764       ENDIF
18765       END
18766
18767 CDECK  ID>, PHO_SELPT
18768       SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18769 C***********************************************************************
18770 C
18771 C    select pt from different distributions
18772 C
18773 C    input:    EE            energy (for initialization only)
18774 C                            otherwise x value of corresponding parton
18775 C              PTLOW         lower pt limit
18776 C              PTHIGH        upper pt limit
18777 C                            (PTHIGH > 20 will cause DEXP underflows)
18778 C
18779 C              IMODE = 0     dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18780 C              IMODE = 1     dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18781 C              IMODE = 2     dNs/dP_t according photon wave function
18782 C              IMODE = 10    no sampling
18783 C
18784 C              IMODE = -100+IMODE    initialization according to
18785 C                                    given limitations
18786 C
18787 C    output:   PTS           sampled pt value
18788 C    initialization:
18789 C              BETA          soft pt slope in central region
18790 C
18791 C***********************************************************************
18792       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18793       SAVE
18794
18795       PARAMETER ( PI2    =  6.28318530718D0,
18796      &            AMIN   =  1.D-2,
18797      &            EPS    =  1.D-7,
18798      &            DEPS   =  1.D-30)
18799
18800 C  input/output channels
18801       INTEGER LI,LO
18802       COMMON /POINOU/ LI,LO
18803 C  event debugging information
18804       INTEGER NMAXD
18805       PARAMETER (NMAXD=100)
18806       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18807      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18808       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18809      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18810 C  model switches and parameters
18811       CHARACTER*8 MDLNA
18812       INTEGER ISWMDL,IPAMDL
18813       DOUBLE PRECISION PARMDL
18814       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18815 C  data of c.m. system of Pomeron / Reggeon exchange
18816       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18817       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18818      &                 SIDP,CODP,SIFP,COFP
18819       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18820      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18821      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18822 C  average number of cut soft and hard ladders (obsolete)
18823       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18824       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18825 C  data needed for soft-pt calculation
18826       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18827       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18828
18829       DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18830       EXTERNAL PHO_CONN0,PHO_CONN1
18831
18832 C  initialization
18833
18834       IF(IMODE.LT.0) GOTO 100
18835
18836       PX = PTHIGH
18837       PTS = 0.D0
18838
18839 C  initial checks
18840
18841       IF(PX.LT.AMIN) RETURN
18842
18843       IF((PX-PTLOW).LT.0.01) THEN
18844         IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18845      &    'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18846         RETURN
18847       ENDIF
18848
18849 C  sampling of pt values according to IMODE
18850
18851       IF(IMODE.EQ.0) THEN
18852
18853         FAC1 = EXP(-BETA*PX**2)
18854         FAC2 = (1.D0-FAC1)
18855  25     CONTINUE
18856           XI1 = DT_RNDM(PX)*FAC2 + FAC1
18857           PTS = SQRT(-1.D0/BETA*LOG(XI1))
18858         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18859
18860       ELSE IF(IMODE.EQ.1) THEN
18861
18862         XIMIN = EXP(-BETA*PTHIGH)
18863         XIDEL = 1.D0-XIMIN
18864  50     CONTINUE
18865           PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18866      &              *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18867         IF(PTS.LT.XMT) GOTO 50
18868         PTS = SQRT(PTS**2-XMT2)
18869         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18870
18871       ELSE IF(IMODE.EQ.2) THEN
18872
18873         IF(EE.GE.0.D0) THEN
18874           P2 = PVIRTP(1)
18875         ELSE
18876           P2 = PVIRTP(2)
18877         ENDIF
18878         XV = ABS(EE)
18879         AA = (1.D0-XV)*XV*P2+PARMDL(25)
18880  75     CONTINUE
18881           PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
18882         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
18883
18884 C  something wrong
18885
18886       ELSE IF(IMODE.NE.10) THEN
18887         WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
18888         CALL PHO_ABORT
18889       ENDIF
18890
18891 C  debug output
18892       IF(IDEB(5).GE.20) THEN
18893         WRITE(LO,'(1X,A,I3,4E10.3)')
18894      &    'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
18895      &    IMODE,BETA,PTLOW,PTHIGH,PTS
18896       ENDIF
18897       RETURN
18898
18899 C  initialization
18900  100  CONTINUE
18901         PTSMIN = PTLOW
18902         PTSMAX = PTHIGH
18903         PTCON = PTHIGH
18904 C  calculation of parameters
18905         INIT = IMODE+100
18906         AAS = 0.D0
18907
18908 C  initialization for model 0 (gaussian pt distribution)
18909
18910         IF(INIT.EQ.0) THEN
18911           BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
18912           BETUP = BETAS(1)
18913           BETLO = -2.D0
18914           XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
18915           IF(XTOL.LT.0.D0) THEN
18916             XTOL = 1.D-4
18917             METHOD = 1
18918             MAXF = 500
18919             BETA = 0.D0
18920             BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
18921 *           IF(BETA.LT.-1.D+10) THEN
18922 *             WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18923 *    &          '(model 0: Ecm,PTcut)',EE,PTCON
18924 *             WRITE(LO,'(1X,A,1P,3E10.3)')
18925 *    &          'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18926 *             CALL PHO_PREVNT(-1)
18927 *             BETA = 0.01
18928 *           ELSE
18929               AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
18930 *           ENDIF
18931           ELSE
18932             AAS = 0.D0
18933             BETA = BETAS(1)
18934           ENDIF
18935
18936 C  initialization for model 1 (exponential pt distribution)
18937
18938         ELSE IF(INIT.EQ.1) THEN
18939           XMT = PARMDL(43)
18940           XMT2 = XMT*XMT
18941           BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
18942           BETUP = BETAS(1)
18943           BETLO = -3.D0
18944           XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
18945           IF(XTOL.LT.0.D0) THEN
18946             XTOL = 1.D-4
18947             METHOD = 1
18948             MAXF = 500
18949             BETA = 0.D0
18950             BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
18951 *           IF(BETA.LT.-1.D+10) THEN
18952 *             WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18953 *    &          '(model 1: Ecm,PTcut)',EE,PTCON
18954 *             WRITE(LO,'(1X,A,1P,3E10.3)')
18955 *    &          'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18956 *             CALL PHO_PREVNT(-1)
18957 *             BETA = 0.01
18958 *           ELSE
18959               AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
18960 *           ENDIF
18961           ELSE
18962             AAS = 0.D0
18963             BETA = BETAS(1)
18964           ENDIF
18965         ELSE IF(INIT.EQ.10) THEN
18966           IF(IDEB(5).GT.10)
18967      &      WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
18968           RETURN
18969         ELSE
18970           WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
18971      &      INIT
18972           CALL PHO_ABORT
18973         ENDIF
18974         BETA = MIN(BETA,BETAS(1))
18975
18976 C  hard cross section is too big: neg. beta parameter
18977         IF(BETA.LE.0.D0) THEN
18978           WRITE(LO,'(1X,A,1P,2E12.3)')
18979      &      'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
18980           WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
18981      &      SIGS,DSIGHP,SIGH,PTCON
18982           CALL PHO_PREVNT(-1)
18983         ENDIF
18984
18985 C  output of initialization parameters
18986         IF(IDEB(5).GE.10) THEN
18987           WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
18988      &      INIT
18989           WRITE(LO,'(5X,A,1P,2E13.3)')
18990      &      'BETA,AAS        ',BETA,AAS
18991           WRITE(LO,'(5X,A,1P,3E13.3)')
18992      &      'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
18993           WRITE(LO,'(5X,A,1P,3E13.3)')
18994      &      'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
18995         ENDIF
18996
18997       END
18998
18999 CDECK  ID>, PHO_CONN0
19000       DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
19001 C***********************************************************************
19002 C
19003 C    auxiliary function to determine parameters of soft
19004 C    pt distribution  dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
19005 C
19006 C    internal factors: FS  number of soft partons in soft Pomeron
19007 C                      FH  number of soft partons in hard Pomeron
19008 C
19009 C***********************************************************************
19010
19011       IMPLICIT NONE
19012
19013       SAVE
19014
19015 C  input/output channels
19016       INTEGER LI,LO
19017       COMMON /POINOU/ LI,LO
19018 C  average number of cut soft and hard ladders (obsolete)
19019       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19020       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19021 C  data needed for soft-pt calculation
19022       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19023       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19024
19025       DOUBLE PRECISION BETA,XX,FF
19026
19027       XX = BETA*PTCON**2
19028       IF(ABS(XX).LT.1.D-3) THEN
19029         FF = FS*SIGS+FH*SIGH
19030      &       - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
19031       ELSE
19032         FF = FS*SIGS+FH*SIGH
19033      &       - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
19034       ENDIF
19035       PHO_CONN0 = FF
19036
19037 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
19038 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19039
19040       END
19041
19042 CDECK  ID>, PHO_CONN1
19043       DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
19044 C***********************************************************************
19045 C
19046 C    auxiliary function to determine parameters of soft
19047 C    pt distribution  dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
19048 C
19049 C    internal factors: FS  number of soft partons in soft Pomeron
19050 C                      FH  number of soft partons in hard Pomeron
19051 C
19052 C***********************************************************************
19053
19054       IMPLICIT NONE
19055
19056       SAVE
19057
19058 C  input/output channels
19059       INTEGER LI,LO
19060       COMMON /POINOU/ LI,LO
19061 C  average number of cut soft and hard ladders (obsolete)
19062       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19063       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19064 C  data needed for soft-pt calculation
19065       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19066       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19067
19068       DOUBLE PRECISION BETA,XX,FF
19069
19070       XX = BETA*PTCON
19071       IF(ABS(XX).LT.1.D-3) THEN
19072         FF = FS*SIGS+FH*SIGH
19073      &       - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
19074       ELSE
19075         FF = FS*SIGS+FH*SIGH
19076      &       - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19077       ENDIF
19078       PHO_CONN1 = FF
19079
19080 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19081 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19082
19083       END
19084
19085 CDECK  ID>, PHO_MSHELL
19086       SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19087 C********************************************************************
19088 C
19089 C    rescaling of momenta of two partons to put both
19090 C                                       on mass shell
19091 C
19092 C    input:       PA1,PA2   input momentum vectors
19093 C                 XM1,2     desired masses of particles afterwards
19094 C                 P1,P2     changed momentum vectors
19095 C
19096 C********************************************************************
19097       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19098       SAVE
19099
19100       PARAMETER ( DEPS   =  1.D-20 )
19101
19102       DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19103
19104 C  input/output channels
19105       INTEGER LI,LO
19106       COMMON /POINOU/ LI,LO
19107 C  event debugging information
19108       INTEGER NMAXD
19109       PARAMETER (NMAXD=100)
19110       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19111      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19112       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19113      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19114 C  internal rejection counters
19115       INTEGER NMXJ
19116       PARAMETER (NMXJ=60)
19117       CHARACTER*10 REJTIT
19118       INTEGER IFAIL
19119       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19120
19121       IREJ = 0
19122       IDEV = 0
19123 C  debug output
19124       IF(IDEB(40).GE.10) THEN
19125         WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19126         WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19127         WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19128         WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19129       ENDIF
19130
19131 C  Lorentz transformation into system CMS
19132       PX = PA1(1)+PA2(1)
19133       PY = PA1(2)+PA2(2)
19134       PZ = PA1(3)+PA2(3)
19135       EE = PA1(4)+PA2(4)
19136       XMS = EE**2-PX**2-PY**2-PZ**2
19137       IF(XMS.LT.(XM1+XM2)**2) THEN
19138         IREJ = 1
19139         IFAIL(37) = IFAIL(37)+1
19140
19141         if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19142
19143         IF(IDEB(40).GE.3) THEN
19144           WRITE(LO,'(/1X,A,I12)')
19145      &      'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19146           WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19147      &      SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19148           WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19149           IDEV = 5
19150           IF(IDEB(40).GE.3) GOTO 55
19151         ENDIF
19152         RETURN
19153       ENDIF
19154       XMS = SQRT(XMS)
19155       BGX = PX/XMS
19156       BGY = PY/XMS
19157       BGZ = PZ/XMS
19158       GAM = EE/XMS
19159       CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19160      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19161 C  rotation angles
19162       PTOT1 = MAX(DEPS,PTOT1)
19163       COD = P1(3)/PTOT1
19164       SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19165       COF = 1.D0
19166       SIF = 0.D0
19167       IF(PTOT1*SID.GT.1.D-5) THEN
19168         COF = P1(1)/(SID*PTOT1)
19169         SIF = P1(2)/(SID*PTOT1)
19170         ANORF = SQRT(COF*COF+SIF*SIF)
19171         COF = COF/ANORF
19172         SIF = SIF/ANORF
19173       ENDIF
19174
19175 C  new CM momentum and energies (for masses XM1,XM2)
19176       XM12 = XM1**2
19177       XM22 = XM2**2
19178       SS   = XMS**2
19179       PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19180       EE1  = SQRT(XM12+PCMP**2)
19181       EE2  = XMS-EE1
19182 C  back rotation
19183       CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19184       CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19185      &           PTOT1,P1(1),P1(2),P1(3),P1(4))
19186       CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19187      &           PTOT2,P2(1),P2(2),P2(3),P2(4))
19188
19189 C  check consistency
19190       DEL = XMS*0.0001
19191       IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19192         IDEV = 1
19193       ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19194         IDEV = 2
19195       ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19196         IDEV = 3
19197       ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19198         IDEV = 4
19199       ENDIF
19200  55   CONTINUE
19201 C  debug output
19202       IF(IDEV.NE.0) THEN
19203         WRITE(LO,'(1X,A,I3)')
19204      &    'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19205         WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19206         WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19207         WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19208         WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19209         WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19210         WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19211         WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19212       ELSE IF(IDEB(40).GE.10) THEN
19213         WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19214         WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19215         WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19216       ENDIF
19217       END
19218
19219 CDECK  ID>, PHO_GLU2QU
19220       SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19221 C********************************************************************
19222 C
19223 C    split gluon with index I in POEVT1
19224 C          (massless gluon assumed)
19225 C
19226 C    input:      /POEVT1/
19227 C                IG      gluon index
19228 C                IQ1     first quark index
19229 C                IQ2     second quark index
19230 C
19231 C    output:     new quarks in /POEVT1/
19232 C                IREJ    1 splitting impossible
19233 C                        0 splitting successful
19234 C
19235 C********************************************************************
19236       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19237       SAVE
19238
19239       PARAMETER ( DEPS   =  1.D-15,
19240      &            EPS    =  1.D-5 )
19241
19242 C  input/output channels
19243       INTEGER LI,LO
19244       COMMON /POINOU/ LI,LO
19245 C  event debugging information
19246       INTEGER NMAXD
19247       PARAMETER (NMAXD=100)
19248       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19249      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19250       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19251      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19252 C  model switches and parameters
19253       CHARACTER*8 MDLNA
19254       INTEGER ISWMDL,IPAMDL
19255       DOUBLE PRECISION PARMDL
19256       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19257
19258 C  standard particle data interface
19259       INTEGER NMXHEP
19260
19261       PARAMETER (NMXHEP=4000)
19262
19263       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19264       DOUBLE PRECISION PHEP,VHEP
19265       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19266      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19267      &                VHEP(4,NMXHEP)
19268 C  extension to standard particle data interface (PHOJET specific)
19269       INTEGER IMPART,IPHIST,ICOLOR
19270       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19271
19272 C  internal rejection counters
19273       INTEGER NMXJ
19274       PARAMETER (NMXJ=60)
19275       CHARACTER*10 REJTIT
19276       INTEGER IFAIL
19277       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19278
19279       DIMENSION P1(4),P2(4)
19280       DATA CUTM  /0.02D0/
19281
19282       IREJ = 0
19283
19284 C  calculate string masses max possible
19285       IF(ISWMDL(9).EQ.1) THEN
19286         CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19287      &     -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19288         IF(CMASS1.LT.CUTM) THEN
19289           IF(IDEB(73).GE.5) THEN
19290             WRITE(LO,'(1X,A,3I4,4E10.3)')
19291      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19292           ENDIF
19293           IFAIL(33) = IFAIL(33) + 1
19294           IREJ = 1
19295           RETURN
19296         ENDIF
19297         CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19298      &     -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19299         IF(CMASS2.LT.CUTM) THEN
19300           IF(IDEB(73).GE.5) THEN
19301             WRITE(LO,'(1X,A,3I4,4E10.3)')
19302      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19303           ENDIF
19304           IFAIL(33) = IFAIL(33) + 1
19305           IREJ = 1
19306           RETURN
19307         ENDIF
19308 C
19309 C  calculate minimal z
19310         ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19311         ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19312         ZMIN = MIN(ZMIN1,ZMIN2)
19313         IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19314           IF(IDEB(73).GE.5) THEN
19315             WRITE(LO,'(1X,A,3I3,4E10.3)')
19316      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19317      &        IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19318           ENDIF
19319           IFAIL(33) = IFAIL(33) + 1
19320           IREJ = 1
19321           RETURN
19322         ENDIF
19323       ELSE
19324         ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19325       ENDIF
19326 C
19327       ZFRAC = PHO_GLUSPL(ZMIN)
19328       IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19329         ZFRAC = 1.D0-ZFRAC
19330       ENDIF
19331       DO 200 I=1,4
19332         P1(I) = PHEP(I,IG)*ZFRAC
19333         P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19334  200  CONTINUE
19335 C  quark flavours
19336       CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19337       CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19338      &              +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19339       CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19340
19341       IF(ABS(IDHEP(IQ1)).GT.6) THEN
19342         K = SIGN(ABS(K),IDHEP(IQ1))
19343       ELSE
19344         K = -SIGN(ABS(K),IDHEP(IQ1))
19345       ENDIF
19346 C  colors
19347       IF(K.GT.0) THEN
19348         IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19349         IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19350       ELSE
19351         IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19352         IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19353       ENDIF
19354 C  register new partons
19355       CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19356      &            IPHIST(1,IG),0,IC1,0,IPOS,1)
19357       CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19358      &            IPHIST(1,IG),0,IC2,0,IPOS,1)
19359 C  debug output
19360       IF(IDEB(73).GE.20) THEN
19361           WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19362      &      'PHO_GLU2QU:','   IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19363      &      IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19364         WRITE(LO,'(1X,A,4I5)') '   flavours, colors  ',
19365      &    K,-K,IC1,IC2
19366       ENDIF
19367       END
19368
19369 CDECK  ID>, PHO_GLUSPL
19370       DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19371 C*********************************************************************
19372 C
19373 C     calculate quark - antiquark light cone momentum fractions
19374 C     according to Altarelli-Parisi g->q aq splitting function
19375 C     (symmetric z interval assumed)
19376 C
19377 C     input: ZMIN    minimal Z value allowed,
19378 C                    1-ZMIN maximal Z value allowed
19379 C
19380 C********************************************************************
19381       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19382       SAVE
19383
19384       PARAMETER ( ALEXP= 0.3333333333D0,
19385      &            DEPS = 1.D-10 )
19386
19387 C  input/output channels
19388       INTEGER LI,LO
19389       COMMON /POINOU/ LI,LO
19390 C  event debugging information
19391       INTEGER NMAXD
19392       PARAMETER (NMAXD=100)
19393       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19394      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19395       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19396      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19397
19398       IF(ZMIN.GE.0.5D0) THEN
19399         IF(IDEB(69).GT.2) THEN
19400           WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19401         ENDIF
19402         ZZ=0.D0
19403         GOTO 1000
19404       ELSE IF(ZMIN.LE.0.D0) THEN
19405         IF(IDEB(69).GT.2) THEN
19406           WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19407         ENDIF
19408         ZMINL = DEPS
19409       ELSE
19410         ZMINL = ZMIN
19411       ENDIF
19412
19413       ZMAX = 1.D0-ZMINL
19414       XI   = DT_RNDM(ZMAX)
19415       ZZ   = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19416       IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19417
19418  1000 CONTINUE
19419       IF(IDEB(69).GE.10) THEN
19420         WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19421       ENDIF
19422       PHO_GLUSPL = ZZ
19423       END
19424
19425 CDECK  ID>, PHO_STDPAR
19426       SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19427 C***********************************************************************
19428 C
19429 C     select the initial parton x-fractions and flavors and
19430 C     the final parton momenta and flavours
19431 C     for standard Pomeron/Reggeon cuts
19432 C
19433 C     input:   IJM1   index of mother particle 1 in /POEVT1/
19434 C              IJM2   index of mother particle 2 in /POEVT1/
19435 C              IGEN   production process of mother particles
19436 C              MSPOM  soft cut Pomerons
19437 C              MHPOM  hard or semihard cut Pomerons
19438 C              MSREG  soft cut Reggeons
19439 C              MHDIR  direct hard processes
19440 C
19441 C              IJM1   -1    initialization of statistics
19442 C                     -2    output of statistics
19443 C
19444 C     output:  partons are directly written to /POEVT1/,/POEVT2/
19445 C
19446 C          structure of /POSOFT/
19447 C               XS1(I),XS2(I):     x-values of initial partons
19448 C               IJSI1(I),IJSI2(I): flavor of initial parton
19449 C                                  0            gluon
19450 C                                  1,2,3,4      quarks
19451 C                                  negative     antiquarks
19452 C               IJSF1(I),IJSF2(I): flavor of final state partons
19453 C               PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19454 C                                J=1   PX
19455 C                                 =2   PY
19456 C                                 =3   PZ
19457 C                                 =4   ENERGY
19458 C
19459 C***********************************************************************
19460       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19461       SAVE
19462
19463       PARAMETER (RHOMAS =  0.766D0,
19464      &           DEPS   =  1.D-10,
19465      &           TINY   =  1.D-10)
19466
19467 C  input/output channels
19468       INTEGER LI,LO
19469       COMMON /POINOU/ LI,LO
19470 C  event debugging information
19471       INTEGER NMAXD
19472       PARAMETER (NMAXD=100)
19473       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19474      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19475       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19476      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19477 C  model switches and parameters
19478       CHARACTER*8 MDLNA
19479       INTEGER ISWMDL,IPAMDL
19480       DOUBLE PRECISION PARMDL
19481       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19482 C  some constants
19483       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19484       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19485      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19486 C  general process information
19487       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19488       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19489 C  global event kinematics and particle IDs
19490       INTEGER IFPAP,IFPAB
19491       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19492       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19493 C  data of c.m. system of Pomeron / Reggeon exchange
19494       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19495       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19496      &                 SIDP,CODP,SIFP,COFP
19497       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19498      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
19499      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
19500 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
19501       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19502       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19503       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19504      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19505 C  obsolete cut-off information
19506       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19507       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19508 C  currently activated parton density parametrizations
19509       CHARACTER*8 PDFNAM
19510       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19511       DOUBLE PRECISION PDFLAM,PDFQ2M
19512       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19513      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19514 C  hard scattering parameters used for most recent hard interaction
19515       INTEGER NFbeta,NF
19516       DOUBLE PRECISION ALQCD2,BQCD
19517       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19518 C  particles created by initial state evolution
19519       INTEGER MXISR1,MXISR2
19520       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19521       INTEGER IFLISR,IPOISR,IMXISR
19522       DOUBLE PRECISION PHISR
19523       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19524      &                IPOISR(2,2,MXISR2),IMXISR(2)
19525 C  light-cone x fractions and c.m. momenta of soft cut string ends
19526       INTEGER MAXSOF
19527       PARAMETER ( MAXSOF = 50 )
19528       INTEGER IJSI2,IJSI1
19529       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19530       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19531      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19532      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
19533 C  table of particle indices for recursive PHOJET calls
19534       INTEGER MAXIPX
19535       PARAMETER ( MAXIPX = 100 )
19536       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19537       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19538      &                IPOIX1,IPOIX2,IPOIX3
19539 C  hard scattering data
19540       INTEGER MSCAHD
19541       PARAMETER ( MSCAHD = 50 )
19542       INTEGER LSCAHD,LSC1HD,LSIDX,
19543      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19544       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19545       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19546      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19547      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19548      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19549      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19550      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19551      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19552
19553 C  standard particle data interface
19554       INTEGER NMXHEP
19555
19556       PARAMETER (NMXHEP=4000)
19557
19558       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19559       DOUBLE PRECISION PHEP,VHEP
19560       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19561      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19562      &                VHEP(4,NMXHEP)
19563 C  extension to standard particle data interface (PHOJET specific)
19564       INTEGER IMPART,IPHIST,ICOLOR
19565       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19566
19567 C  internal rejection counters
19568       INTEGER NMXJ
19569       PARAMETER (NMXJ=60)
19570       CHARACTER*10 REJTIT
19571       INTEGER IFAIL
19572       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19573 C  internal cross check information on hard scattering limits
19574       DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19575       COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19576 C  hard cross sections and MC selection weights
19577       INTEGER Max_pro_2
19578       PARAMETER ( Max_pro_2 = 16 )
19579       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19580      &  MH_acc_1,MH_acc_2
19581       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19582       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19583      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19584      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19585      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19586      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19587
19588       double precision pho_alphas
19589
19590       DIMENSION PC(4),IFLA(2),ICI(2,2)
19591
19592       IF(IJM1.EQ.-1) THEN
19593         DO 116 I=1,15
19594           ETAMI(1,I) = 1.D10
19595           ETAMA(1,I) = -1.D10
19596           ETAMI(2,I) = 1.D10
19597           ETAMA(2,I) = -1.D10
19598           XXMI(1,I) = 1.D0
19599           XXMA(1,I) = 0.D0
19600           XXMI(2,I) = 1.D0
19601           XXMA(2,I) = 0.D0
19602  116    CONTINUE
19603         CALL PHO_HARSCA(IJM1,1)
19604         CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19605
19606         RETURN
19607
19608       ELSE IF(IJM1.EQ.-2) THEN
19609
19610 C  output internal statistics
19611         IF(IDEB(23).GE.1) THEN
19612           WRITE(LO,'(/1X,A)')
19613      &      'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19614           DO 117 I=1,15
19615             WRITE(LO,'(5X,I3,4E13.5)')
19616      &        I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19617  117      CONTINUE
19618           WRITE(LO,'(1X,A)')
19619      &      'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19620           DO 118 I=1,15
19621             WRITE(LO,'(5X,I3,4E13.5)')
19622      &        I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
19623  118      CONTINUE
19624         ENDIF
19625         CALL PHO_HARSCA(IJM1,1)
19626         CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19627
19628         RETURN
19629       ENDIF
19630
19631       IREJ   = 0
19632 C  debug output
19633       IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19634   221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19635
19636 C  get mother data (exchange if first particle is a pomeron)
19637       IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19638         JM1 = IJM2
19639         JM2 = IJM1
19640       ELSE
19641         JM1 = IJM1
19642         JM2 = IJM2
19643       ENDIF
19644
19645       NPOSP(1) = JM1
19646       NPOSP(2) = JM2
19647       IDPDG1 = IDHEP(JM1)
19648       IDBAM1 = IMPART(JM1)
19649       IDPDG2 = IDHEP(JM2)
19650       IDBAM2 = IMPART(JM2)
19651
19652 C  store current status of /POEVT1/
19653       KHPOMS = KHPOM
19654       KSPOMS = KSPOM
19655       KSREGS = KSREG
19656       KHDIRS = KHDIR
19657       NHEPS  = NHEP
19658       IPOIS1 = IPOIX1
19659       IPOIS2 = IPOIX2
19660
19661 C  get nominal masses (photons: VDM assumption)
19662       DELMAS = 0.D0
19663       IF(IDHEP(JM1).EQ.22) THEN
19664         PMASSP(1) = RHOMAS+DELMAS
19665         PVIRTP(1) = PHEP(5,JM1)**2
19666       ELSE
19667         PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19668         PVIRTP(1) = 0.D0
19669       ENDIF
19670       IF(IDHEP(JM2).EQ.22) THEN
19671         PMASSP(2) = RHOMAS+DELMAS
19672         PVIRTP(2) = PHEP(5,JM2)**2
19673       ELSE
19674         PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19675         PVIRTP(2) = 0.D0
19676       ENDIF
19677
19678 C  calculate c.m. energy and check kinematics
19679       PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19680       PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19681       PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19682       PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19683       SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19684
19685       IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19686         WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19687      &    'energy smaller than two-particle threshold (event rejected)'
19688         CALL PHO_PREVNT(1)
19689         IREJ = 5
19690         GOTO 150
19691       ENDIF
19692       ECMP = SQRT(SS)
19693
19694       IF(IDEB(23).GE.5) THEN
19695         WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19696      &    'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19697         IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19698       ENDIF
19699
19700 C  Lorentz transformation into c.m. system
19701       DO 10 I=1,4
19702         GAMBEP(I) = PC(I)/ECMP
19703  10   CONTINUE
19704       CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19705      &           PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19706      &           PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19707 C  rotation angle: particle 1 moves along +z
19708       CODP = PC(3)/PTOT1
19709       SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19710       COFP = 1.D0
19711       SIFP = 0.D0
19712       IF(PTOT1*SIDP.GT.1.D-5) THEN
19713         COFP = PC(1)/(SIDP*PTOT1)
19714         SIFP = PC(2)/(SIDP*PTOT1)
19715         ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19716         COFP = COFP/ANORF
19717         SIFP = SIFP/ANORF
19718       ENDIF
19719 C  get CM momentum
19720       XM12 = PMASSP(1)**2
19721       XM22 = PMASSP(2)**2
19722       PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19723
19724 C  find particle combination
19725       II = 0
19726       IF(IDPDG2.EQ.IFPAP(2)) THEN
19727         IF(IDPDG1.EQ.IFPAP(1)) II = 1
19728       ELSE IF(IDPDG2.EQ.990) THEN
19729         IF(IDPDG1.EQ.IFPAP(1)) THEN
19730           II = 2
19731         ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19732           II = 3
19733         ELSE IF(IDPDG1.EQ.990) THEN
19734           II = 4
19735         ENDIF
19736       ENDIF
19737       IF(II.EQ.0) THEN
19738         IF(ISWMDL(14).GT.0) THEN
19739           II = 1
19740         ELSE
19741           WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19742      &      'invalid particle combination:',IDPDG1,IDPDG2
19743           CALL PHO_ABORT
19744         ENDIF
19745       ENDIF
19746
19747 C  select parton distribution functions from tables
19748       IF((MHPOM+MHDIR).GT.0) THEN
19749         CALL PHO_ACTPDF(IDPDG1,1)
19750         CALL PHO_ACTPDF(IDPDG2,2)
19751 C  initialize alpha_s calculation
19752         DUMMY = PHO_ALPHAS(0.D0,-4)
19753       ENDIF
19754
19755 C  interpolate hard cross sections and rejection weights
19756       CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19757      &            -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19758
19759       NTRY   = 10
19760
19761 C  position of first particle added to /POEVT2/
19762       NLOR1 = NHEP+1
19763
19764 C  ---------------- direct processes -----------------
19765
19766       IF(MHDIR.EQ.1) THEN
19767         CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19768         IF(IREJ.EQ.50) RETURN
19769         IF(IREJ.NE.0) GOTO 150
19770 C  write comments to /POEVT1/
19771         CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19772      &    X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19773      &    IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19774         CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19775      &    PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19776      &    ICA1,ICA2,IPOS,1)
19777         CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19778      &    PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19779      &    ICA1,ICA2,IPOS,1)
19780         CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19781      &    PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19782      &    IPOS1,1)
19783         CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19784      &    PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19785      &    IPOS2,1)
19786
19787 C  soft spectator partons
19788         ICA1  = 0
19789         ICA2  = 0
19790         ICB1  = 0
19791         ICB2  = 0
19792         IPDF1 = 0
19793         IPDF2 = 0
19794
19795 C  single resolved: QCD compton scattering
19796 C ------------------------------
19797         IF(NPROHD(1).EQ.10) THEN
19798 C  register hadron remnant
19799           CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19800           IPDF2 = 1000*IGRP(2)+ISET(2)
19801         ELSE IF(NPROHD(1).EQ.12) THEN
19802 C  register hadron remnant
19803           CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19804           IPDF1 = 1000*IGRP(1)+ISET(1)
19805
19806 C  single resolved: photon gluon fusion
19807 C ---------------------------
19808         ELSE IF(NPROHD(1).EQ.11) THEN
19809 C  register hadron remnant
19810           CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19811           IPDF2 = 1000*IGRP(2)+ISET(2)
19812         ELSE IF(NPROHD(1).EQ.13) THEN
19813 C  register hadron remnant
19814           CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19815           IPDF1 = 1000*IGRP(1)+ISET(1)
19816
19817 C  direct process (no remnant)
19818 C ----------------------------
19819         ELSE IF(NPROHD(1).EQ.14) THEN
19820
19821         ENDIF
19822
19823 C  write final high-pt partons to POEVT1
19824         IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19825           ICI(1,1) = ICA1
19826           ICI(1,2) = ICA2
19827           ICI(2,1) = ICB1
19828           ICI(2,2) = ICB2
19829           I = 1
19830           IFLA(1) = NINHD(I,1)
19831           IFLA(2) = NINHD(I,2)
19832 C  initial state radiation
19833           DO 130 K=1,2
19834             DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19835               KK = 1
19836  137          CONTINUE
19837               IFLB = IFLISR(K,IPA)
19838               IF(ABS(IFLB).LE.6) THEN
19839 C  partons
19840                 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19841                   IF(IFLB.EQ.0) THEN
19842                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19843      &                ICI(K,1),ICI(K,2),3)
19844                   ELSE IF(IFLB.GT.0) THEN
19845                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19846      &                ICI(K,1),ICI(K,2),4)
19847                   ELSE
19848                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19849      &                IC1,IC2,4)
19850                   ENDIF
19851                 ELSE
19852                   IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19853                     IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19854                       CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19855                       KK = KK+1
19856                       GOTO 137
19857                     ENDIF
19858                   ENDIF
19859                   IF(IFLB.EQ.0) THEN
19860                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19861      &                IC1,IC2,2)
19862                   ELSE
19863                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19864      &                ICI(K,1),ICI(K,2),2)
19865                   ENDIF
19866                 ENDIF
19867                 IIFL = IPHO_CNV1(IFLB)
19868
19869                 IFLA(K) = IFLA(K)-IFLB
19870                 IST = -1
19871               ELSE
19872 C  other particle
19873                 IIFL = IFLB
19874                 IC1 = 0
19875                 IC2 = 0
19876                 IST = 1
19877               ENDIF
19878               CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
19879      &          PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
19880      &          IGEN,IC1,IC2,IPOS,1)
19881  135        CONTINUE
19882  130      CONTINUE
19883           ICOLOR(1,IPOS1-2) = ICI(1,1)
19884           ICOLOR(2,IPOS1-2) = ICI(1,2)
19885           ICOLOR(1,IPOS1-1) = ICI(2,1)
19886           ICOLOR(2,IPOS1-1) = ICI(2,2)
19887           CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
19888      &      IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
19889      &      NOUTHD(I,2),ICI(2,1),ICI(2,2))
19890           ICOLOR(1,IPOS1) = ICI(1,1)
19891           ICOLOR(2,IPOS1) = ICI(1,2)
19892           ICOLOR(1,IPOS2) = ICI(2,1)
19893           ICOLOR(2,IPOS2) = ICI(2,2)
19894           DO 140 K=1,2
19895             IPA = IPOISR(K,1,I)
19896             CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
19897      &        PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
19898      &        PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
19899  140      CONTINUE
19900         ELSE
19901           ICOLOR(1,IPOS1-2) = ICA1
19902           ICOLOR(2,IPOS1-2) = ICA2
19903           ICOLOR(1,IPOS1-1) = ICB1
19904           ICOLOR(2,IPOS1-1) = ICB2
19905           CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
19906      &      NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
19907      &      NOUTHD(1,2),ICB1,ICB2)
19908           ICOLOR(1,IPOS1) = ICA1
19909           ICOLOR(2,IPOS1) = ICA2
19910           ICOLOR(1,IPOS2) = ICB1
19911           ICOLOR(2,IPOS2) = ICB2
19912           I = -1
19913           IF(ABS(NOUTHD(1,1)).GT.12) I = 1
19914           CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
19915      &      PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
19916           CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
19917      &      PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
19918         ENDIF
19919
19920 C  assign soft pt to spectators
19921         IF(ISWMDL(18).EQ.0) THEN
19922           IPOS2 = IPOS2-1
19923           CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
19924           IF(IREJ.NE.0) THEN
19925             IFAIL(26) = IFAIL(26) + 1
19926             GOTO 150
19927           ENDIF
19928
19929         ENDIF
19930
19931 C  ----------------- resolved processes -------------------
19932
19933 C  single Reggeon exchange
19934 C ----------------------------
19935       ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
19936 C  flavours
19937         CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
19938         IF(IREJ.NE.0) THEN
19939           IFAIL(24) = IFAIL(24)+1
19940           GOTO 150
19941         ENDIF
19942
19943 C  colors
19944         CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19945         IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
19946      &     .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
19947           CALL PHO_SWAPI(ICA1,ICB1)
19948         ENDIF
19949         ECMH = ECMP/2.D0
19950
19951 C  registration
19952
19953 C  DPMJET call with special projectile / target
19954         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
19955           CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
19956      &               ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
19957           CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
19958      &               ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
19959 C  default treatment
19960         ELSE
19961           CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
19962      &      -1,IGEN,ICA1,0,IPOS1,1)
19963           CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
19964      &      -1,IGEN,ICB1,0,IPOS2,1)
19965         ENDIF
19966
19967 C  soft pt assignment
19968         IF(ISWMDL(18).EQ.0) THEN
19969           CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19970           IF(IREJ.NE.0) THEN
19971             IFAIL(25) = IFAIL(25) + 1
19972             GOTO 150
19973           ENDIF
19974         ENDIF
19975 C
19976 C  multi Reggeon / Pomeron exchange
19977 C----------------------------------------
19978       ELSE
19979 C  parton configuration
19980
19981         CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
19982      &              MHPAR1,MHPAR2,IREJ)
19983
19984         IF(IREJ.EQ.50) RETURN
19985         IF(IREJ.NE.0) GOTO 150
19986
19987 C  register particles
19988         IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
19989      &    'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
19990      &    MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
19991
19992 C  register soft partons
19993         IF(IVAL1.NE.0) THEN
19994           IF(IVAL1.LT.0) THEN
19995             IND1 = 3
19996             IVAL1=-IVAL1
19997           ELSE
19998             IND1 = 2
19999           ENDIF
20000         ELSE IF(MSPOM.EQ.0) THEN
20001           IND1 = 4
20002         ELSE
20003           IND1 = 1
20004         ENDIF
20005         IF(IVAL2.NE.0) THEN
20006           IF(IVAL2.LT.0) THEN
20007             IND2 = 3
20008             IVAL2=-IVAL2
20009           ELSE
20010             IND2 = 2
20011           ENDIF
20012         ELSE IF(MSPOM.EQ.0) THEN
20013           IND2 = 4
20014         ELSE
20015           IND2 = 1
20016         ENDIF
20017
20018         IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
20019      &    'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
20020
20021 C  soft Pomeron final states
20022 C -----------------------------------
20023         K = MSPOM+MHPOM+MSREG
20024         DO 50 I=1,MSPOM
20025
20026           CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
20027           IF(IREJ.NE.0) THEN
20028             IFAIL(8) = IFAIL(8) + 1
20029             GOTO 150
20030           ENDIF
20031 C
20032  50     CONTINUE
20033
20034 C  soft Reggeon final states
20035 C -----------------------------------------
20036         DO 75 I=1,MSREG
20037 C  flavours
20038           CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
20039           IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
20040             CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
20041           ELSE
20042             CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
20043           ENDIF
20044
20045 C  colors
20046           CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
20047           IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
20048      &      .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
20049      &      CALL PHO_SWAPI(ICA1,ICB1)
20050 C  registration
20051           CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
20052      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
20053      &      I,IGEN,ICA1,ICA2,IPOS1,1)
20054           IND1 = IND1+1
20055           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
20056      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
20057      &      I,IGEN,ICB1,ICB2,IPOS2,1)
20058           IND2 = IND2+1
20059
20060           IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
20061      &      'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
20062      &      IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
20063
20064 C  soft pt assignment
20065           IF(ISWMDL(18).EQ.0) THEN
20066             CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20067             IF(IREJ.NE.0) THEN
20068               IFAIL(25) = IFAIL(25) + 1
20069               GOTO 150
20070             ENDIF
20071           ENDIF
20072
20073  75     CONTINUE
20074
20075 C  hard Pomeron final states
20076 C ------------------------------------
20077         IND1 = MSPAR1
20078         IND2 = MSPAR2
20079
20080         DO 100 L=1,MHPOM
20081           I = LSIDX(L)
20082
20083           IFLI1 = IPHO_CNV1(N0INHD(I,1))
20084           IFLI2 = IPHO_CNV1(N0INHD(I,2))
20085           IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20086           IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20087
20088 C  write comments to /POEVT1/
20089           CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20090      &      X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20091      &      IFLO1,IFLO2,IPOS,1)
20092           I1 = 8*I-7
20093           IPDF = 1000*IGRP(1)+ISET(1)
20094           CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20095      &      PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20096      &      ICA1,ICA2,IPOS,1)
20097           IPDF = 1000*IGRP(2)+ISET(2)
20098           CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20099      &      PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20100      &      ICB1,ICB2,IPOS,1)
20101           I1 = 8*I-3
20102           IPDF = 1000*IGRP(1)+ISET(1)
20103           CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20104      &      PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20105      &      ICA1,ICA2,IPOS1,1)
20106           IPDF = 1000*IGRP(2)+ISET(2)
20107           CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20108      &      PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20109      &      ICB1,ICB2,IPOS2,1)
20110
20111 C  spectator partons belonging to hard interaction
20112           IF(IVAL1.EQ.I) THEN
20113             IVQ = 1
20114             IND = 1
20115           ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20116             IVQ = 0
20117             IND = 1
20118           ELSE
20119             IVQ = -1
20120             IND = IND1
20121           ENDIF
20122           CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20123           IF(IVQ.LT.0) IND1 = IND1-IUSED
20124           IF(IVAL2.EQ.I) THEN
20125             IVQ = 1
20126             IND = 1
20127           ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20128             IVQ = 0
20129             IND = 1
20130           ELSE
20131             IVQ = -1
20132             IND = IND2
20133           ENDIF
20134           CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20135           IF(IVQ.LT.0) IND2 = IND2-IUSED
20136 C
20137 C  register hard scattered partons
20138           IF((ISWMDL(8).GE.2)
20139      &       .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20140             ICI(1,1) = ICA1
20141             ICI(1,2) = ICA2
20142             ICI(2,1) = ICB1
20143             ICI(2,2) = ICB2
20144             IFLA(1) = NINHD(I,1)
20145             IFLA(2) = NINHD(I,2)
20146 C  initial state radiation
20147             DO 230 K=1,2
20148               DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20149                 KK = 1
20150  237            CONTINUE
20151                 IFLB = IFLISR(K,IPA)
20152                 IF(ABS(IFLB).LE.6) THEN
20153 C  partons
20154                   IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20155                     IF(IFLB.EQ.0) THEN
20156                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20157      &                  ICI(K,1),ICI(K,2),3)
20158                     ELSE IF(IFLB.GT.0) THEN
20159                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20160      &                  ICI(K,1),ICI(K,2),4)
20161                     ELSE
20162                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20163      &                  ICI(K,2),IC1,IC2,4)
20164                     ENDIF
20165                   ELSE
20166                     IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20167                       IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20168                         CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20169                         KK = KK+1
20170                         GOTO 237
20171                       ENDIF
20172                     ENDIF
20173                     IF(IFLB.EQ.0) THEN
20174                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20175      &                  ICI(K,2),IC1,IC2,2)
20176                     ELSE
20177                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20178      &                  ICI(K,1),ICI(K,2),2)
20179                     ENDIF
20180                   ENDIF
20181                   IIFL = IPHO_CNV1(IFLB)
20182
20183                   IFLA(K)  = IFLA(K)-IFLB
20184                   IST = -1
20185                 ELSE
20186 C  other particles
20187                   IIFL = IFLB
20188                   IC1 = 0
20189                   IC2 = 0
20190                   IST = 1
20191                 ENDIF
20192                 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20193      &            PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20194      &            L*100+K,IGEN,IC1,IC2,IPOS,1)
20195  235          CONTINUE
20196  230        CONTINUE
20197             ICOLOR(1,IPOS1-2) = ICI(1,1)
20198             ICOLOR(2,IPOS1-2) = ICI(1,2)
20199             ICOLOR(1,IPOS1-1) = ICI(2,1)
20200             ICOLOR(2,IPOS1-1) = ICI(2,2)
20201             CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20202      &        IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20203      &        NOUTHD(I,2),ICI(2,1),ICI(2,2))
20204             ICOLOR(1,IPOS1) = ICI(1,1)
20205             ICOLOR(2,IPOS1) = ICI(1,2)
20206             ICOLOR(1,IPOS2) = ICI(2,1)
20207             ICOLOR(2,IPOS2) = ICI(2,2)
20208             DO 240 K=1,2
20209               IPA = IPOISR(K,1,I)
20210               CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20211      &          PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20212      &          PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20213  240        CONTINUE
20214           ELSE
20215             ICOLOR(1,IPOS1-2) = ICA1
20216             ICOLOR(2,IPOS1-2) = ICA2
20217             ICOLOR(1,IPOS1-1) = ICB1
20218             ICOLOR(2,IPOS1-1) = ICB2
20219             CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20220      &        NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20221      &        NOUTHD(I,2),ICB1,ICB2)
20222             ICOLOR(1,IPOS1) = ICA1
20223             ICOLOR(2,IPOS1) = ICA2
20224             ICOLOR(1,IPOS2) = ICB1
20225             ICOLOR(2,IPOS2) = ICB2
20226             I1 = 8*I-3
20227             CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20228      &        PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20229      &        ICA1,ICA2,IPOS,1)
20230             CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20231      &        PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20232      &        ICB1,ICB2,IPOS,1)
20233           ENDIF
20234  100    CONTINUE
20235 C  end of resolved parton registration
20236       ENDIF
20237
20238       IF(MHDIR+MHPOM.GT.0) THEN
20239
20240         IF(ISWMDL(29).GE.1) THEN
20241 C  primordial kt of hard scattering
20242           CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20243           IF(IREJ.NE.0) THEN
20244             IFAIL(27) = IFAIL(27)+1
20245             GOTO 150
20246           ENDIF
20247         ELSE IF(ISWMDL(24).GE.0) THEN
20248 C  give "soft" pt only to soft (spectator) partons in hard processes
20249           CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20250           IF(IREJ.NE.0) THEN
20251             IFAIL(26) = IFAIL(26)+1
20252             GOTO 150
20253           ENDIF
20254         ENDIF
20255
20256       ENDIF
20257
20258 C  give "soft" pt to partons in soft Pomerons
20259       IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20260         CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20261         IF(IREJ.NE.0) THEN
20262           IFAIL(25) = IFAIL(25) + 1
20263           GOTO 150
20264         ENDIF
20265       ENDIF
20266
20267 C  boost back to lab frame
20268       CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20269      &  GAMBEP(1),GAMBEP(2),GAMBEP(3))
20270       RETURN
20271
20272 C  rejection treatment
20273  150  CONTINUE
20274       IFAIL(2) = IFAIL(2)+1
20275 C  reset counters
20276       KSPOM = KSPOMS
20277       KHPOM = KHPOMS
20278       KHDIR = KHDIRS
20279       KSREG = KSREGS
20280 C  reset mother-daugther relations
20281       JDAHEP(1,JM1) = 0
20282       JDAHEP(2,JM1) = 0
20283       JDAHEP(1,JM2) = 0
20284       JDAHEP(2,JM2) = 0
20285       ISTHEP(JM1) = 1
20286       ISTHEP(JM2) = 1
20287       IPOIX1 = IPOIS1
20288       IPOIX2 = IPOIS2
20289       NHEP   = NHEPS
20290 C  debug
20291       IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20292      &  'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20293      &  MSPOM,MHPOM,MSREG,MHDIR
20294       RETURN
20295
20296       END
20297
20298 CDECK  ID>, PHO_HARCOL
20299       SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20300      &                  IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20301 C*********************************************************************
20302 C
20303 C     calculate color flow for hard resolved process
20304 C
20305 C     input:    IP1..4  flavour of partons (PDG convention)
20306 C               V       parton subprocess Mandelstam variable  V = t/s
20307 C                       (lightcone momenta assumed)
20308 C               ICA,ICB color labels
20309 C               MSPR    process number
20310 C                       -1   initialization of statistics
20311 C                       -2   output of statistics
20312 C
20313 C     output:   ICC,ICD color label of final partons
20314 C
20315 C     (it is possible to use the same variables for in and output)
20316 C
20317 C**********************************************************************
20318       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20319       SAVE
20320
20321 C  input/output channels
20322       INTEGER LI,LO
20323       COMMON /POINOU/ LI,LO
20324 C  event debugging information
20325       INTEGER NMAXD
20326       PARAMETER (NMAXD=100)
20327       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20328      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20329       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20330      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20331 C  model switches and parameters
20332       CHARACTER*8 MDLNA
20333       INTEGER ISWMDL,IPAMDL
20334       DOUBLE PRECISION PARMDL
20335       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20336 C  names of hard scattering processes
20337       INTEGER Max_pro_1
20338       PARAMETER ( Max_pro_1 = 16 )
20339       CHARACTER*18 PROC
20340       COMMON /POHPRO/ PROC(0:Max_pro_1)
20341
20342       DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20343
20344 C  initialization
20345       IF(MSPR.EQ.-1) THEN
20346         DO 200 I=1,8
20347           DO 210 K=1,5
20348             ICONF(I,K) = 0
20349  210      CONTINUE
20350           IRECN(I,1) = 0
20351           IRECN(I,2) = 0
20352  200    CONTINUE
20353         RETURN
20354 C  output of statistics
20355       ELSE IF(MSPR.EQ.-2) THEN
20356         IF(IDEB(26).LT.1) RETURN
20357         WRITE(LO,'(/1X,A,/1X,A)')
20358      &    'PHO_HARCOL: sampled color configurations',
20359      &    '----------------------------------------'
20360         WRITE(LO,'(6X,A,15X,A)')
20361      &    'diagram                  color configurations (1-4)','sum'
20362         DO 300 I=1,8
20363           DO 310 K=1,4
20364             ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20365  310      CONTINUE
20366           WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20367  300    CONTINUE
20368         IF(ISWMDL(11).GE.2) THEN
20369           WRITE(LO,'(/6X,A)')
20370      &      'diagram             with   /   without color re-connection'
20371           DO 320 I=1,8
20372             WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20373  320      CONTINUE
20374         ENDIF
20375         RETURN
20376       ENDIF
20377 C
20378 C  gluons: first color positive, quarks second color zero
20379       IF(IP1.EQ.0) THEN
20380         IF(ICA1.LT.0) THEN
20381           I = ICA2
20382           ICA2 = ICA1
20383           ICA1 = I
20384         ENDIF
20385       ELSE
20386         ICA2 = 0
20387       ENDIF
20388       IF(IP2.EQ.0) THEN
20389         IF(ICB1.LT.0) THEN
20390           I = ICB2
20391           ICB2 = ICB1
20392           ICB1 = I
20393         ENDIF
20394       ELSE
20395         ICB2 = 0
20396       ENDIF
20397       IC2 = 0
20398       IC4 = 0
20399 C  debug output
20400       IF(IDEB(26).GE.15)
20401      &  WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20402      &  'PHO_HARCOL: process',MSPR,
20403      &  'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20404 C
20405       IRC = 0
20406       IF(IPAMDL(21).EQ.1) THEN
20407 C
20408 C  soft color re-connection option
20409 C
20410         IF(MSPR.EQ.1) THEN
20411 C  hard g g final state, only g g --> g g
20412           IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20413             IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20414               IC1 = ICA1
20415               IC2 = ICA2
20416               IC3 = ICB1
20417               IC4 = ICB2
20418               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20419               IRC = 1
20420               GOTO 100
20421             ENDIF
20422           ENDIF
20423         ELSE IF(MSPR.EQ.3) THEN
20424 C  hard q g final state
20425           IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20426             IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20427               IC1 = ICA1
20428               IC2 = ICA2
20429               IC3 = ICB1
20430               IC4 = ICB2
20431               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20432               IRC = 1
20433               GOTO 100
20434             ENDIF
20435           ENDIF
20436         ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20437 C  hard q q final state
20438           IF(ICA1.NE.-ICB1) THEN
20439             IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20440               IC1 = ICA1
20441               IC2 = ICA2
20442               IC3 = ICB1
20443               IC4 = ICB2
20444               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20445               IRC = 1
20446               GOTO 100
20447             ENDIF
20448           ENDIF
20449         ENDIF
20450         IRECN(MSPR,2) = IRECN(MSPR,2)+1
20451       ENDIF
20452 C
20453       IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20454 C
20455 C  large Nc limit of all graphs
20456 C
20457         IF(MSPR.EQ.1) THEN
20458 C  g g --> g g
20459           IF(DT_RNDM(V).GT.0.5D0) THEN
20460             IC1 = ICB1
20461             IC2 = ICA2
20462             IC3 = ICA1
20463             IC4 = ICB2
20464             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20465           ELSE
20466             IC1 = ICA1
20467             IC2 = ICB2
20468             IC3 = ICB1
20469             IC4 = ICA2
20470             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20471           ENDIF
20472         ELSE IF(MSPR.EQ.2) THEN
20473 C  q qb --> g g
20474           CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20475           IF(ICA1.LT.0) THEN
20476             IC1 = I1
20477             IC2 = ICA1
20478             IC3 = ICB1
20479             IC4 = I2
20480             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20481           ELSE
20482             IC1 = ICA1
20483             IC2 = I2
20484             IC3 = I1
20485             IC4 = ICB1
20486             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20487           ENDIF
20488         ELSE IF(MSPR.EQ.3) THEN
20489 C  q g --> q g
20490           IF(DT_RNDM(V).LT.0.5D0) THEN
20491             IF(IP1+IP2.GT.0) THEN
20492               IC1 = ICB1
20493               IC2 = ICA2
20494               IC3 = ICA1
20495               IC4 = ICB2
20496             ELSE IF(IP1.LT.0) THEN
20497               IC1 = ICB2
20498               IC3 = ICB1
20499               IC4 = ICA1
20500             ELSE
20501               IC1 = ICA1
20502               IC2 = ICB1
20503               IC3 = ICA2
20504             ENDIF
20505             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20506           ELSE
20507             IF(IP1.GT.0) THEN
20508               CALL PHO_HARCOR(-ICA1,ICB2)
20509               IC1 = ICA1
20510               IC3 = ICB1
20511               IC4 = -ICA1
20512             ELSE IF(IP2.GT.0) THEN
20513               CALL PHO_HARCOR(-ICB1,ICA2)
20514               IC1 = ICA1
20515               IC2 = -ICB1
20516               IC3 = ICB1
20517             ELSE IF(IP1.LT.0) THEN
20518               CALL PHO_HARCOR(-ICA1,ICB1)
20519               IC1 = ICA1
20520               IC3 = -ICA1
20521               IC4 = ICB2
20522             ELSE IF(IP2.LT.0) THEN
20523               CALL PHO_HARCOR(-ICB1,ICA1)
20524               IC1 = -ICB1
20525               IC2 = ICA2
20526               IC3 = ICB1
20527             ENDIF
20528             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20529           ENDIF
20530         ELSE IF(MSPR.EQ.4) THEN
20531 C  g g --> q qb
20532           IC1 = ICA1
20533           IC3 = ICB2
20534           CALL PHO_HARCOR(-ICB1,ICA2)
20535           IF(ICB2.EQ.-ICB1) IC3 = ICA2
20536           IF(IP3*IC1.LT.0) THEN
20537             I = IC1
20538             IC1 = IC3
20539             IC3 = I
20540           ENDIF
20541           ICONF(MSPR,2) = ICONF(MSPR,2)+1
20542         ELSE IF(MSPR.EQ.5) THEN
20543 C  q qb --> q qb
20544           IF(DT_RNDM(V).LT.0.5D0) THEN
20545             IF(ICA1*IP3.LT.0) THEN
20546               IC1 = ICB1
20547               IC3 = ICA1
20548             ELSE
20549               IC1 = ICA1
20550               IC3 = ICB1
20551             ENDIF
20552             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20553           ELSE
20554             IF(ICA1*IP3.LT.0) THEN
20555               IC1 = -ICA1
20556               IC3 = ICA1
20557             ELSE
20558               IC1 = ICA1
20559               IC3 = -ICA1
20560             ENDIF
20561             CALL PHO_HARCOR(-ICA1,ICB1)
20562             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20563           ENDIF
20564         ELSE IF(MSPR.EQ.6) THEN
20565 C  q qb --> qp qbp
20566           IF(ICA1*IP3.LT.0) THEN
20567             IC1 = ICB1
20568             IC3 = ICA1
20569             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20570           ELSE
20571             IC1 = ICA1
20572             IC3 = ICB1
20573             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20574           ENDIF
20575         ELSE IF(MSPR.EQ.7) THEN
20576 C  q q --> q q
20577           IF(DT_RNDM(V).LT.0.5D0) THEN
20578             IC1 = ICA1
20579             IC3 = ICB1
20580             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20581           ELSE
20582             IC1 = ICB1
20583             IC3 = ICA1
20584             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20585           ENDIF
20586         ELSE IF(MSPR.EQ.8) THEN
20587 C  q qp --> q qp
20588           IF(IP1*IP2.GT.0) THEN
20589             IF(IP3.EQ.IP1) THEN
20590               IC1 = ICB1
20591               IC3 = ICA1
20592             ELSE
20593               IC1 = ICA1
20594               IC3 = ICB1
20595             ENDIF
20596             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20597           ELSE
20598             IF(ICA1*IP3.LT.0) THEN
20599               IC1 = -ICA1
20600               IC3 = ICA1
20601             ELSE
20602               IC1 = ICA1
20603               IC3 = -ICA1
20604             ENDIF
20605             CALL PHO_HARCOR(-ICA1,ICB1)
20606             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20607           ENDIF
20608         ELSE
20609 C  unknown process
20610           WRITE(LO,'(/1X,A,I3)')
20611      &      'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20612           CALL PHO_ABORT
20613         ENDIF
20614 C
20615       ELSE
20616 C
20617 C  color flow according to QCD leading order matrix element
20618 C
20619         U = -(1.D0+V)
20620         IF(MSPR.EQ.1) THEN
20621 C  g g --> g g
20622           PC(1) = 1/V**2  +2.D0/V    +3.D0  +2.D0*V    +V**2
20623           PC(2) = 1/U**2  +2.D0/U    +3.D0  +2.D0*U    +U**2
20624           PC(3) = (V/U)**2+2.D0*(V/U)+3.D0  +2.D0*(U/V)+(U/V)**2
20625           XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20626           PCS = 0.D0
20627           DO 110 I=1,3
20628             PCS = PCS+PC(I)
20629             IF(XI.LT.PCS) GOTO 120
20630  110      CONTINUE
20631  120      CONTINUE
20632           IF(I.EQ.1) THEN
20633             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20634             IF(DT_RNDM(V).GT.0.5D0) THEN
20635               IC1 = I1
20636               IC2 = ICA2
20637               IC3 = ICB1
20638               IC4 = I2
20639               CALL PHO_HARCOR(-ICB2,ICA1)
20640               IF(ICB1.EQ.-ICB2) IC3 = ICA1
20641             ELSE
20642               IC1 = ICA1
20643               IC2 = I2
20644               IC3 = I1
20645               IC4 = ICB2
20646               CALL PHO_HARCOR(-ICB1,ICA2)
20647               IF(ICB2.EQ.-ICB1) IC4 = ICA2
20648             ENDIF
20649           ELSE IF(I.EQ.2) THEN
20650             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20651             IF(DT_RNDM(U).GT.0.5D0) THEN
20652               IC1 = ICB1
20653               IC2 = I2
20654               IC3 = I1
20655               IC4 = ICA2
20656               CALL PHO_HARCOR(-ICB2,ICA1)
20657               IF(ICB1.EQ.-ICB2) IC1 = ICA1
20658             ELSE
20659               IC1 = I1
20660               IC2 = ICB2
20661               IC3 = ICA1
20662               IC4 = I2
20663               CALL PHO_HARCOR(-ICB1,ICA2)
20664               IF(ICB2.EQ.-ICB1) IC2 = ICA2
20665             ENDIF
20666           ELSE
20667             IF(DT_RNDM(V).GT.0.5D0) THEN
20668               IC1 = ICB1
20669               IC2 = ICA2
20670               IC3 = ICA1
20671               IC4 = ICB2
20672             ELSE
20673               IC1 = ICA1
20674               IC2 = ICB2
20675               IC3 = ICB1
20676               IC4 = ICA2
20677             ENDIF
20678           ENDIF
20679           ICONF(MSPR,I) = ICONF(MSPR,I)+1
20680         ELSE IF(MSPR.EQ.2) THEN
20681 C  q qb --> g g
20682           PC(1) = U/V-2.D0*U**2
20683           PC(2) = V/U-2.D0*V**2
20684           CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20685           XI = (PC(1)+PC(2))*DT_RNDM(U)
20686           IF(XI.LT.PC(1)) THEN
20687             IF(ICA1.GT.0) THEN
20688               IC1 = ICA1
20689               IC2 = I2
20690               IC3 = I1
20691               IC4 = ICB1
20692               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20693             ELSE
20694               IC1 = I1
20695               IC2 = ICA1
20696               IC3 = ICB1
20697               IC4 = I2
20698               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20699             ENDIF
20700           ELSE
20701             IF(ICA1.GT.0) THEN
20702               IC1 = I1
20703               IC2 = ICB1
20704               IC3 = ICA1
20705               IC4 = I2
20706               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20707             ELSE
20708               IC1 = ICB1
20709               IC2 = I2
20710               IC3 = I1
20711               IC4 = ICA1
20712               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20713             ENDIF
20714           ENDIF
20715         ELSE IF(MSPR.EQ.3) THEN
20716 C  q g --> q g
20717           PC(1) = 2.D0*(U/V)**2-U
20718           PC(2) = 2.D0/V**2-1.D0/U
20719           XI = (PC(1)+PC(2))*DT_RNDM(V)
20720           IF(XI.LT.PC(1)) THEN
20721             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20722             IF(IP1.GT.0) THEN
20723               IC1 = I1
20724               IC3 = ICB1
20725               IC4 = I2
20726               CALL PHO_HARCOR(-ICA1,ICB2)
20727               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20728             ELSE IF(IP1.LT.0) THEN
20729               IC1 = I2
20730               IC3 = I1
20731               IC4 = ICB2
20732               CALL PHO_HARCOR(-ICA1,ICB1)
20733               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20734             ELSE IF(IP2.GT.0) THEN
20735               IC1 = ICA1
20736               IC2 = I2
20737               IC3 = I1
20738               CALL PHO_HARCOR(-ICB1,ICA2)
20739               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20740             ELSE
20741               IC1 = I1
20742               IC2 = ICA2
20743               IC3 = I2
20744               CALL PHO_HARCOR(-ICB1,ICA1)
20745               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20746             ENDIF
20747           ELSE
20748             IF(IP1.GT.0) THEN
20749               IC1 = ICB1
20750               IC3 = ICA1
20751               IC4 = ICB2
20752               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20753             ELSE IF(IP1.LT.0) THEN
20754               IC1 = ICB2
20755               IC3 = ICB1
20756               IC4 = ICA1
20757               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20758             ELSE IF(IP2.GT.0) THEN
20759               IC1 = ICB1
20760               IC2 = ICA2
20761               IC3 = ICA1
20762               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20763             ELSE
20764               IC1 = ICA1
20765               IC2 = ICB1
20766               IC3 = ICA2
20767               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20768             ENDIF
20769           ENDIF
20770         ELSE IF(MSPR.EQ.4) THEN
20771 C  g g --> q qb
20772           PC(1) = U/V-2.D0*U**2
20773           PC(2) = V/U-2.D0*V**2
20774           XI = (PC(1)+PC(2))*DT_RNDM(U)
20775           IF(XI.LT.PC(1)) THEN
20776             IF(IP3.GT.0) THEN
20777               IC1 = ICA1
20778               IC3 = ICB2
20779               CALL PHO_HARCOR(-ICB1,ICA2)
20780               IF(ICB2.EQ.-ICB1) IC3 = ICA2
20781               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20782             ELSE
20783               IC1 = ICA2
20784               IC3 = ICB1
20785               CALL PHO_HARCOR(-ICB2,ICA1)
20786               IF(ICB1.EQ.-ICB2) IC3 = ICA1
20787               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20788             ENDIF
20789           ELSE
20790             IF(IP3.GT.0) THEN
20791               IC1 = ICB1
20792               IC3 = ICA2
20793               CALL PHO_HARCOR(-ICB2,ICA1)
20794               IF(ICB1.EQ.-ICB2) IC1 = ICA1
20795               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20796             ELSE
20797               IC1 = ICB2
20798               IC3 = ICA1
20799               CALL PHO_HARCOR(-ICB1,ICA2)
20800               IF(ICB2.EQ.-ICB1) IC1 = ICA2
20801               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20802             ENDIF
20803           ENDIF
20804         ELSE IF(MSPR.EQ.5) THEN
20805 C  q qb --> q qb
20806           PC(1) = (1.D0+U**2)/V**2
20807           PC(2) = (V**2+U**2)
20808           XI = (PC(1)+PC(2))*DT_RNDM(V)
20809           IF(XI.LT.PC(1)) THEN
20810             CALL PHO_HARCOR(-ICB1,ICA1)
20811             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20812             IF(IP3.GT.0) THEN
20813               IC1 = I1
20814               IC3 = I2
20815               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20816             ELSE
20817               IC1 = I2
20818               IC3 = I1
20819               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20820             ENDIF
20821           ELSE
20822             IF(IP3.GT.0) THEN
20823               IC1 = MAX(ICA1,ICB1)
20824               IC3 = MIN(ICA1,ICB1)
20825               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20826             ELSE
20827               IC1 = MIN(ICA1,ICB1)
20828               IC3 = MAX(ICA1,ICB1)
20829               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20830             ENDIF
20831           ENDIF
20832         ELSE IF(MSPR.EQ.6) THEN
20833 C  q qb --> qp qpb
20834           IF(IP3.GT.0) THEN
20835             IC1 = MAX(ICA1,ICB1)
20836             IC3 = MIN(ICA1,ICB1)
20837             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20838           ELSE
20839             IC1 = MIN(ICA1,ICB1)
20840             IC3 = MAX(ICA1,ICB1)
20841             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20842           ENDIF
20843         ELSE IF(MSPR.EQ.7) THEN
20844 C  q q --> q q
20845           PC(1) = (1.D0+U**2)/V**2
20846           PC(2) = (1.D0+V**2)/U**2
20847           XI = (PC(1)+PC(2))*DT_RNDM(U)
20848           IF(XI.LT.PC(1)) THEN
20849             IC1 = ICB1
20850             IC3 = ICA1
20851             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20852           ELSE
20853             IC1 = ICA1
20854             IC3 = ICB1
20855             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20856           ENDIF
20857         ELSE IF(MSPR.EQ.8) THEN
20858 C  q qp --> q qp
20859           IF(IP1*IP2.LT.0) THEN
20860             CALL PHO_HARCOR(-ICB1,ICA1)
20861             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20862             IF(IP1.GT.0) THEN
20863               IC1 = I1
20864               IC3 = I2
20865               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20866             ELSE
20867               IC1 = I2
20868               IC3 = I1
20869               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20870             ENDIF
20871           ELSE
20872             IC1 = ICB1
20873             IC3 = ICA1
20874             ICONF(MSPR,3) = ICONF(MSPR,3)+1
20875           ENDIF
20876
20877         ELSE IF(MSPR.EQ.10) THEN
20878 C  gam q --> q g
20879           CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
20880           IF(IP3.EQ.0) THEN
20881             CALL PHO_SWAPI(IC1,IC3)
20882             CALL PHO_SWAPI(IC2,IC4)
20883           ENDIF
20884         ELSE IF(MSPR.EQ.11) THEN
20885 C  gam g --> q q
20886           IC1 = ICB1
20887           IC3 = ICB2
20888           IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20889         ELSE IF(MSPR.EQ.12) THEN
20890 C  q gam --> q g
20891           CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
20892           IF(IP3.EQ.0) THEN
20893             CALL PHO_SWAPI(IC1,IC3)
20894             CALL PHO_SWAPI(IC2,IC4)
20895           ENDIF
20896         ELSE IF(MSPR.EQ.13) THEN
20897 C  g gam --> q q
20898           IC1 = ICA1
20899           IC3 = ICA2
20900           IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20901         ELSE IF(MSPR.EQ.14) THEN
20902           IF(ABS(IP3).GT.12) THEN
20903             IC1 = 0
20904             IC3 = 0
20905           ELSE
20906             CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
20907             IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20908           ENDIF
20909         ELSE
20910 C  unknown process
20911           WRITE(LO,'(/1X,A,I3)')
20912      &      'PHO_HARCOL:ERROR:invalid process number',MSPR
20913           CALL PHO_ABORT
20914         ENDIF
20915       ENDIF
20916 C
20917  100  CONTINUE
20918 C  debug output
20919       IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
20920      &    'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
20921 C  color connection?
20922 *     IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
20923 *    &  (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
20924 *    &  .OR.(IC2.EQ.0))) THEN
20925 C  color exchange?
20926 *       IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
20927 *    &     .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
20928 *         IF(IRC.NE.1) THEN
20929 *           WRITE(LO,'(1X,A,I10,I3)')
20930 *    &        'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
20931 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20932 *    &        'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20933 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20934 *    &        'final partons and colors  ',IP3,IC1,IC2,IP4,IC3,IC4
20935 *         ENDIF
20936 *         IRC = 0
20937 *       ENDIF
20938 *     ENDIF
20939 *     IF(IRC.EQ.1) THEN
20940 *           WRITE(LO,'(1X,A,I10,I3)')
20941 *    &        'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
20942 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20943 *    &        'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20944 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20945 *    &        'final partons and colors  ',IP3,IC1,IC2,IP4,IC3,IC4
20946 *     ENDIF
20947 C
20948       ICC1 = IC1
20949       ICC2 = IC2
20950       ICD1 = IC3
20951       ICD2 = IC4
20952
20953       END
20954
20955 CDECK  ID>, PHO_HARCOR
20956       SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
20957 C***********************************************************************
20958 C
20959 C     substituite color in /POEVT2/
20960 C
20961 C     input:    ICOLD   old color
20962 C               ICNEW   new color
20963 C
20964 C***********************************************************************
20965       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20966       SAVE
20967
20968 C  input/output channels
20969       INTEGER LI,LO
20970       COMMON /POINOU/ LI,LO
20971
20972 C  standard particle data interface
20973       INTEGER NMXHEP
20974
20975       PARAMETER (NMXHEP=4000)
20976
20977       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
20978       DOUBLE PRECISION PHEP,VHEP
20979       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
20980      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
20981      &                VHEP(4,NMXHEP)
20982 C  extension to standard particle data interface (PHOJET specific)
20983       INTEGER IMPART,IPHIST,ICOLOR
20984       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
20985
20986       DO 100 I=NHEP,3,-1
20987         IF(ISTHEP(I).EQ.-1) THEN
20988           IF(ICOLOR(1,I).EQ.ICOLD) THEN
20989             ICOLOR(1,I) = ICNEW
20990             RETURN
20991           ELSE IF(IDHEP(I).EQ.21) THEN
20992             IF(ICOLOR(2,I).EQ.ICOLD) THEN
20993               ICOLOR(2,I) = ICNEW
20994               RETURN
20995             ENDIF
20996           ENDIF
20997 *       ELSE IF(ISTHEP(I).EQ.20) THEN
20998 *         IF(ICOLOR(1,I).EQ.-ICOLD) THEN
20999 *           print LO,' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
21000 *           ICOLOR(1,I) = -ICNEW
21001 *           RETURN
21002 *         ELSE IF(IDHEP(I).EQ.21) THEN
21003 *           IF(ICOLOR(2,I).EQ.-ICOLD) THEN
21004 *             print LO,' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
21005 *             ICOLOR(2,I) = -ICNEW
21006 *             RETURN
21007 *           ENDIF
21008 *         ENDIF
21009         ENDIF
21010  100  CONTINUE
21011       END
21012
21013 CDECK  ID>, PHO_HARREM
21014       SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
21015      &                      IUSED,IREJ)
21016 C***********************************************************************
21017 C
21018 C     sample color structure for initial quark/gluon of hard scattering
21019 C     and write hadron remnant to /POEVT1/
21020 C
21021 C     input:    JM1,2   index of mother particle in POEVT1
21022 C               IGEN    mother particle production process
21023 C               IHPOS   hard pomeron number
21024 C               INDXH   index of hard parton
21025 C                       positive for labels 1
21026 C                       negative for labels 2
21027 C               IVAL     1  hard valence parton
21028 C                        0  hard sea parton connected by color flow with
21029 C                           valence quarks
21030 C                       -1  hard sea parton independent off valence
21031 C                           quarks
21032 C               INDXS   index of soft partons needed
21033 C
21034 C     output:   IC1,IC2 color label of initial parton
21035 C               IUSED   number of soft X values used
21036 C               IREJ    rejection flag
21037 C
21038 C**********************************************************************
21039       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21040       SAVE
21041
21042       PARAMETER ( TINY   =  1.D-10 )
21043
21044 C  input/output channels
21045       INTEGER LI,LO
21046       COMMON /POINOU/ LI,LO
21047 C  event debugging information
21048       INTEGER NMAXD
21049       PARAMETER (NMAXD=100)
21050       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21051      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21052       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21053      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21054 C  model switches and parameters
21055       CHARACTER*8 MDLNA
21056       INTEGER ISWMDL,IPAMDL
21057       DOUBLE PRECISION PARMDL
21058       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21059 C  data of c.m. system of Pomeron / Reggeon exchange
21060       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21061       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21062      &                 SIDP,CODP,SIFP,COFP
21063       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21064      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
21065      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
21066 C  obsolete cut-off information
21067       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21068       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21069 C  light-cone x fractions and c.m. momenta of soft cut string ends
21070       INTEGER MAXSOF
21071       PARAMETER ( MAXSOF = 50 )
21072       INTEGER IJSI2,IJSI1
21073       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21074       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21075      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21076      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
21077 C  hard scattering data
21078       INTEGER MSCAHD
21079       PARAMETER ( MSCAHD = 50 )
21080       INTEGER LSCAHD,LSC1HD,LSIDX,
21081      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21082       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21083       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21084      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21085      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21086      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21087      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21088      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21089      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21090
21091 C  standard particle data interface
21092       INTEGER NMXHEP
21093
21094       PARAMETER (NMXHEP=4000)
21095
21096       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21097       DOUBLE PRECISION PHEP,VHEP
21098       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21099      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21100      &                VHEP(4,NMXHEP)
21101 C  extension to standard particle data interface (PHOJET specific)
21102       INTEGER IMPART,IPHIST,ICOLOR
21103       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21104
21105 C  internal rejection counters
21106       INTEGER NMXJ
21107       PARAMETER (NMXJ=60)
21108       CHARACTER*10 REJTIT
21109       INTEGER IFAIL
21110       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21111
21112       IREJ = 0
21113
21114       INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21115
21116       IF(INDXH.GT.0) THEN
21117         IJH = IPHO_CNV1(NINHD(INDXH,1))
21118       ELSE
21119         IJH = IPHO_CNV1(NINHD(-INDXH,2))
21120       ENDIF
21121 C  direct process (photon or pomeron)
21122       IUSED = 0
21123       IC1   = 0
21124       IC2   = 0
21125       IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21126
21127       IHP = 100*ABS(IHPOS)
21128       IVSW = 1
21129 ***************************************
21130 *     IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21131 ***************************************
21132
21133       IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21134      &  'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21135      &  JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21136
21137 C  quark
21138 C****************************************************************
21139
21140         IF(IJH.NE.21) THEN
21141
21142 C  valence quark engaged in hard scattering
21143           IF(IVAL.EQ.1) THEN
21144             CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21145             IF(IREJ.NE.0) THEN
21146               WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21147      &          'invalid valence flavour requested JM,IFLA',JM1,IJH
21148               return
21149             ENDIF
21150             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21151             IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21152      &         .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21153               I = ICA1
21154               ICA1 = ICB1
21155               ICB1 = I
21156             ENDIF
21157 C  remnant of hadron
21158             IF(INDXH.GT.0) THEN
21159               P1 = PSOFT1(1,INDXS)
21160               P2 = PSOFT1(2,INDXS)
21161               P3 = PSOFT1(3,INDXS)
21162               P4 = PSOFT1(4,INDXS)
21163               IJSI1(INDXS) = IREM
21164             ELSE
21165               P1 = PSOFT2(1,INDXS)
21166               P2 = PSOFT2(2,INDXS)
21167               P3 = PSOFT2(3,INDXS)
21168               P4 = PSOFT2(4,INDXS)
21169               IJSI2(INDXS) = IREM
21170             ENDIF
21171 C  registration
21172             CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21173      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21174             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21175      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21176      &        IREM,IPOS,SIGN(INDXS,INDXH)
21177
21178             IUSED = 1
21179
21180 C  sea quark engaged in hard scattering, valence quarks treated
21181           ELSE IF(IVAL.EQ.0) THEN
21182             IF(INDXH.GT.0) THEN
21183               E1 = PSOFT1(4,INDXS)
21184               E2 = PSOFT1(4,INDXS+1)
21185             ELSE
21186               E1 = PSOFT2(4,INDXS)
21187               E2 = PSOFT2(4,INDXS+1)
21188             ENDIF
21189             CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21190             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21191             IF(DT_RNDM(P1).LT.0.5D0) THEN
21192               CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21193             ELSE
21194               CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21195             ENDIF
21196             IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21197      &         .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21198               I = ICA1
21199               ICA1 = ICB1
21200               ICB1 = I
21201             ENDIF
21202             IF(INDXH.GT.0) THEN
21203               P1 = PSOFT1(1,INDXS)
21204               P2 = PSOFT1(2,INDXS)
21205               P3 = PSOFT1(3,INDXS)
21206               P4 = PSOFT1(4,INDXS)
21207               IJSI1(INDXS) = IVFL1
21208             ELSE
21209               P1 = PSOFT2(1,INDXS)
21210               P2 = PSOFT2(2,INDXS)
21211               P3 = PSOFT2(3,INDXS)
21212               P4 = PSOFT2(4,INDXS)
21213               IJSI2(INDXS) = IVFL1
21214             ENDIF
21215 C  registration
21216             CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21217      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21218             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21219      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21220      &        IVFL1,IPOS,SIGN(INDXS,INDXH)
21221
21222 C
21223             IF(INDXH.GT.0) THEN
21224               P1 = PSOFT1(1,INDXS+1)
21225               P2 = PSOFT1(2,INDXS+1)
21226               P3 = PSOFT1(3,INDXS+1)
21227               P4 = PSOFT1(4,INDXS+1)
21228               IJSI1(INDXS+1) = IVFL2
21229             ELSE
21230               P1 = PSOFT2(1,INDXS+1)
21231               P2 = PSOFT2(2,INDXS+1)
21232               P3 = PSOFT2(3,INDXS+1)
21233               P4 = PSOFT2(4,INDXS+1)
21234               IJSI2(INDXS+1) = IVFL2
21235             ENDIF
21236 C  registration
21237             CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21238      &                  IHP,IGEN,ICB1,IVSW,IPOS,1)
21239             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21240      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21241      &        IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21242
21243 C
21244             IF(IJH.LT.0) THEN
21245               ICB1 = ICC2
21246               ICA1 = ICC1
21247             ELSE
21248               ICB1 = ICC1
21249               ICA1 = ICC2
21250             ENDIF
21251             IF(INDXH.GT.0) THEN
21252               P1 = PSOFT1(1,INDXS+2)
21253               P2 = PSOFT1(2,INDXS+2)
21254               P3 = PSOFT1(3,INDXS+2)
21255               P4 = PSOFT1(4,INDXS+2)
21256               IJSI1(INDXS+2) = -IJH
21257             ELSE
21258               P1 = PSOFT2(1,INDXS+2)
21259               P2 = PSOFT2(2,INDXS+2)
21260               P3 = PSOFT2(3,INDXS+2)
21261               P4 = PSOFT2(4,INDXS+2)
21262               IJSI2(INDXS+2) = -IJH
21263             ENDIF
21264 C  registration
21265             CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21266      &                      IHP,IGEN,ICA1,0,IPOS,1)
21267             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21268      &        'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21269      &        -IJH,IPOS,SIGN(INDXS+2,INDXH)
21270             IUSED = 3
21271 C
21272 C  sea quark engaged in hard scattering, valences treated separately
21273           ELSE IF(IVAL.EQ.-1) THEN
21274             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21275             IF(IJH.GT.0) THEN
21276               ICC1 = ICB1
21277               ICB1 = ICA1
21278               ICA1 = ICC1
21279             ENDIF
21280             IF(INDXH.GT.0) THEN
21281               P1 = PSOFT1(1,INDXS)
21282               P2 = PSOFT1(2,INDXS)
21283               P3 = PSOFT1(3,INDXS)
21284               P4 = PSOFT1(4,INDXS)
21285               IJSI1(INDXS) = -IJH
21286             ELSE
21287               P1 = PSOFT2(1,INDXS)
21288               P2 = PSOFT2(2,INDXS)
21289               P3 = PSOFT2(3,INDXS)
21290               P4 = PSOFT2(4,INDXS)
21291               IJSI2(INDXS) = -IJH
21292             ENDIF
21293 C  registration
21294             CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21295      &                      IHP,IGEN,ICA1,0,IPOS,1)
21296             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21297      &        'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21298      &        -IJH,IPOS,SIGN(INDXS,INDXH)
21299
21300             IUSED = 1
21301           ELSE
21302             WRITE(LO,'(1X,A,2I5)')
21303      &        'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21304      &        IVAL,IJH
21305             CALL PHO_ABORT
21306           ENDIF
21307 C
21308           IC1 = ICB1
21309           IC2 = 0
21310 C
21311 C  gluon
21312 C****************************************************************
21313 C
21314 C  gluon from valence quarks
21315         ELSE
21316           IF(IVAL.EQ.1) THEN
21317 C  purely gluonic pomeron remnant
21318             IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21319               IF(INDXH.GT.0) THEN
21320                 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21321                 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21322                 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21323                 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21324                 IJSI1(INDXS) = 0
21325               ELSE
21326                 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21327                 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21328                 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21329                 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21330                 IJSI2(INDXS) = 0
21331               ENDIF
21332               IFL1 = 21
21333               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21334               IF(DT_RNDM(P2).LT.0.5D0) THEN
21335                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21336               ELSE
21337                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21338               ENDIF
21339 C  registration
21340               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21341      &                        IHP,IGEN,ICA1,ICB1,IPOS,1)
21342               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21343      &          'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21344      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21345
21346               IUSED = 2
21347 C  valence quark remnant
21348             ELSE
21349               IF(INDXH.GT.0) THEN
21350                 E1 = PSOFT1(4,INDXS)
21351                 E2 = PSOFT1(4,INDXS+1)
21352               ELSE
21353                 E1 = PSOFT2(4,INDXS)
21354                 E2 = PSOFT2(4,INDXS+1)
21355               ENDIF
21356               CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21357               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21358               IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21359      &           .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21360                 I = ICA1
21361                 ICA1 = ICB1
21362                 ICB1 = I
21363               ENDIF
21364               IF(DT_RNDM(P2).LT.0.5D0) THEN
21365                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21366               ELSE
21367                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21368               ENDIF
21369 C  remnant of hadron
21370               IF(INDXH.GT.0) THEN
21371                 P1 = PSOFT1(1,INDXS)
21372                 P2 = PSOFT1(2,INDXS)
21373                 P3 = PSOFT1(3,INDXS)
21374                 P4 = PSOFT1(4,INDXS)
21375                 IJSI1(INDXS) = IFL1
21376               ELSE
21377                 P1 = PSOFT2(1,INDXS)
21378                 P2 = PSOFT2(2,INDXS)
21379                 P3 = PSOFT2(3,INDXS)
21380                 P4 = PSOFT2(4,INDXS)
21381                 IJSI2(INDXS) = IFL1
21382               ENDIF
21383 C  registration
21384               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21385      &                        IHP,IGEN,ICA1,IVSW,IPOS,1)
21386               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21387      &          'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21388      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21389
21390 C
21391               IF(INDXH.GT.0) THEN
21392                 P1 = PSOFT1(1,INDXS+1)
21393                 P2 = PSOFT1(2,INDXS+1)
21394                 P3 = PSOFT1(3,INDXS+1)
21395                 P4 = PSOFT1(4,INDXS+1)
21396                 IJSI1(INDXS+1) = IFL2
21397               ELSE
21398                 P1 = PSOFT2(1,INDXS+1)
21399                 P2 = PSOFT2(2,INDXS+1)
21400                 P3 = PSOFT2(3,INDXS+1)
21401                 P4 = PSOFT2(4,INDXS+1)
21402                 IJSI2(INDXS+1) = IFL2
21403               ENDIF
21404 C  registration
21405               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21406      &                        IHP,IGEN,ICB1,IVSW,IPOS,1)
21407               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21408      &          'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21409      &          IFL2,IPOS,SIGN(INDXS+1,INDXH)
21410
21411               IUSED = 2
21412             ENDIF
21413 C
21414 C  gluon from sea quarks connected with valence quarks
21415           ELSE IF(IVAL.EQ.0) THEN
21416             IF(INDXH.GT.0) THEN
21417               E1 = PSOFT1(4,INDXS)
21418               E2 = PSOFT1(4,INDXS+1)
21419             ELSE
21420               E1 = PSOFT2(4,INDXS)
21421               E2 = PSOFT2(4,INDXS+1)
21422             ENDIF
21423             CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21424             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21425             IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21426      &         .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21427               I = ICA1
21428               ICA1 = ICB1
21429               ICB1 = I
21430             ENDIF
21431             IF(DT_RNDM(P3).LT.0.5D0) THEN
21432               CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21433             ELSE
21434               CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21435             ENDIF
21436 C  remnant of hadron
21437             IF(INDXH.GT.0) THEN
21438               P1 = PSOFT1(1,INDXS)
21439               P2 = PSOFT1(2,INDXS)
21440               P3 = PSOFT1(3,INDXS)
21441               P4 = PSOFT1(4,INDXS)
21442               IJSI1(INDXS) = IFL1
21443             ELSE
21444               P1 = PSOFT2(1,INDXS)
21445               P2 = PSOFT2(2,INDXS)
21446               P3 = PSOFT2(3,INDXS)
21447               P4 = PSOFT2(4,INDXS)
21448               IJSI2(INDXS) = IFL1
21449             ENDIF
21450 C  registration
21451             CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21452      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21453             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21454      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21455      &        IFL1,IPOS,SIGN(INDXS,INDXH)
21456
21457 C
21458             IF(INDXH.GT.0) THEN
21459               P1 = PSOFT1(1,INDXS+1)
21460               P2 = PSOFT1(2,INDXS+1)
21461               P3 = PSOFT1(3,INDXS+1)
21462               P4 = PSOFT1(4,INDXS+1)
21463               IJSI1(INDXS+1) = IFL2
21464             ELSE
21465               P1 = PSOFT2(1,INDXS+1)
21466               P2 = PSOFT2(2,INDXS+1)
21467               P3 = PSOFT2(3,INDXS+1)
21468               P4 = PSOFT2(4,INDXS+1)
21469               IJSI2(INDXS+1) = IFL2
21470             ENDIF
21471 C  registration
21472             CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21473      &                      IHP,IGEN,ICB1,IVSW,IPOS,1)
21474             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21475      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21476      &        IFL2,IPOS,SIGN(INDXS+1,INDXH)
21477
21478             IF(IPAMDL(18).EQ.0)  THEN
21479 C  sea quark pair
21480               CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21481               IF(ICC1.GT.0) THEN
21482                 IFL1 = ABS(IFL1)
21483                 IFL2 = -IFL1
21484               ELSE
21485                 IFL1 = -ABS(IFL1)
21486                 IFL2 = -IFL1
21487               ENDIF
21488               IF(DT_RNDM(P4).LT.0.5D0) THEN
21489                 ICB1 = ICC2
21490                 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21491               ELSE
21492                 ICA1 = ICC1
21493                 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21494               ENDIF
21495               IF(INDXH.GT.0) THEN
21496                 P1 = PSOFT1(1,INDXS+2)
21497                 P2 = PSOFT1(2,INDXS+2)
21498                 P3 = PSOFT1(3,INDXS+2)
21499                 P4 = PSOFT1(4,INDXS+2)
21500                 IJSI1(INDXS+2) = IFL1
21501               ELSE
21502                 P1 = PSOFT2(1,INDXS+2)
21503                 P2 = PSOFT2(2,INDXS+2)
21504                 P3 = PSOFT2(3,INDXS+2)
21505                 P4 = PSOFT2(4,INDXS+2)
21506                 IJSI2(INDXS+2) = IFL1
21507               ENDIF
21508 C  registration
21509               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21510      &                        IHP,IGEN,ICA1,0,IPOS,1)
21511               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21512      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21513      &          IFL1,IPOS,SIGN(INDXS+2,INDXH)
21514
21515 C
21516               IF(INDXH.GT.0) THEN
21517                 P1 = PSOFT1(1,INDXS+3)
21518                 P2 = PSOFT1(2,INDXS+3)
21519                 P3 = PSOFT1(3,INDXS+3)
21520                 P4 = PSOFT1(4,INDXS+3)
21521                 IJSI1(INDXS+3) = IFL2
21522               ELSE
21523                 P1 = PSOFT2(1,INDXS+3)
21524                 P2 = PSOFT2(2,INDXS+3)
21525                 P3 = PSOFT2(3,INDXS+3)
21526                 P4 = PSOFT2(4,INDXS+3)
21527                 IJSI2(INDXS+3) = IFL2
21528               ENDIF
21529 C  registration
21530               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21531      &                        IHP,IGEN,ICB1,0,IPOS,1)
21532               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21533      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21534      &          IFL2,IPOS,SIGN(INDXS+3,INDXH)
21535
21536               IUSED = 4
21537             ELSE
21538               IUSED = 2
21539             ENDIF
21540 C
21541 C  gluon from independent sea quarks
21542           ELSE IF(IVAL.EQ.-1) THEN
21543             IF(IPAMDL(18).EQ.0) THEN
21544               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21545               CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21546               IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21547      &           .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21548                 I = ICA1
21549                 ICA1 = ICB1
21550                 ICB1 = I
21551               ENDIF
21552               IF(DT_RNDM(P1).LT.0.5D0) THEN
21553                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21554               ELSE
21555                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21556               ENDIF
21557 C  remainder of hadron
21558               IF(INDXH.GT.0) THEN
21559                 P1 = PSOFT1(1,INDXS)
21560                 P2 = PSOFT1(2,INDXS)
21561                 P3 = PSOFT1(3,INDXS)
21562                 P4 = PSOFT1(4,INDXS)
21563                 IJSI1(INDXS) = IFL1
21564               ELSE
21565                 P1 = PSOFT2(1,INDXS)
21566                 P2 = PSOFT2(2,INDXS)
21567                 P3 = PSOFT2(3,INDXS)
21568                 P4 = PSOFT2(4,INDXS)
21569                 IJSI2(INDXS) = IFL1
21570               ENDIF
21571 C  registration
21572               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21573      &                        IHP,IGEN,ICA1,ICA2,IPOS,1)
21574               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21575      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21576      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21577
21578 C  remnant of sea
21579               IF(INDXH.GT.0) THEN
21580                 P1 = PSOFT1(1,INDXS-1)
21581                 P2 = PSOFT1(2,INDXS-1)
21582                 P3 = PSOFT1(3,INDXS-1)
21583                 P4 = PSOFT1(4,INDXS-1)
21584                 IJSI1(INDXS-1) = IFL2
21585               ELSE
21586                 P1 = PSOFT2(1,INDXS-1)
21587                 P2 = PSOFT2(2,INDXS-1)
21588                 P3 = PSOFT2(3,INDXS-1)
21589                 P4 = PSOFT2(4,INDXS-1)
21590                 IJSI2(INDXS-1) = IFL2
21591               ENDIF
21592 C  registration
21593               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21594      &                        IHP,IGEN,ICB1,ICB2,IPOS,1)
21595               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21596      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21597      &          IFL2,IPOS,SIGN(INDXS-1,INDXH)
21598
21599               IUSED = 2
21600             ELSE
21601               CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21602               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21603      &          'PHO_HARREM: no spectator added:(INDXS)',
21604      &          SIGN(INDXS,INDXH)
21605               IUSED = 0
21606             ENDIF
21607 C
21608           ELSE
21609             WRITE(LO,'(1X,A,2I5)')
21610      &        'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21611      &        IVAL,IJH
21612             CALL PHO_ABORT
21613           ENDIF
21614           IC1 = ICC1
21615           IC2 = ICC2
21616         ENDIF
21617       END
21618
21619 CDECK  ID>, PHO_HARDIR
21620       SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21621      &                      IREJ)
21622 C**********************************************************************
21623 C
21624 C     parton orientated formulation of direct scattering processes
21625 C
21626 C     input:
21627 C
21628 C     output:   II        particle combination (1..4)
21629 C               IVAL1,2   0 no valence quarks engaged
21630 C                         1 valence quarks engaged
21631 C               MSPAR1,2  number of realized soft partons
21632 C               MHPAR1,2  number of realized hard partons
21633 C               IREJ      1 failure
21634 C                         0 success
21635 C
21636 C**********************************************************************
21637       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21638       SAVE
21639
21640 C  input/output channels
21641       INTEGER LI,LO
21642       COMMON /POINOU/ LI,LO
21643 C  event debugging information
21644       INTEGER NMAXD
21645       PARAMETER (NMAXD=100)
21646       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21647      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21648       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21649      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21650 C  model switches and parameters
21651       CHARACTER*8 MDLNA
21652       INTEGER ISWMDL,IPAMDL
21653       DOUBLE PRECISION PARMDL
21654       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21655 C  hard scattering parameters used for most recent hard interaction
21656       INTEGER NFbeta,NF
21657       DOUBLE PRECISION ALQCD2,BQCD
21658       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21659 C  data of c.m. system of Pomeron / Reggeon exchange
21660       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21661       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21662      &                 SIDP,CODP,SIFP,COFP
21663       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21664      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
21665      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
21666 C  obsolete cut-off information
21667       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21668       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21669 C  hard cross sections and MC selection weights
21670       INTEGER Max_pro_2
21671       PARAMETER ( Max_pro_2 = 16 )
21672       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21673      &  MH_acc_1,MH_acc_2
21674       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21675       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21676      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21677      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21678      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21679      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21680 C  data on most recent hard scattering
21681       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21682       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21683      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21684      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21685       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21686      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21687      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21688      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21689      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21690 C  light-cone x fractions and c.m. momenta of soft cut string ends
21691       INTEGER MAXSOF
21692       PARAMETER ( MAXSOF = 50 )
21693       INTEGER IJSI2,IJSI1
21694       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21695       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21696      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21697      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
21698 C  hard scattering data
21699       INTEGER MSCAHD
21700       PARAMETER ( MSCAHD = 50 )
21701       INTEGER LSCAHD,LSC1HD,LSIDX,
21702      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21703       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21704       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21705      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21706      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21707      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21708      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21709      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21710      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21711 C  internal rejection counters
21712       INTEGER NMXJ
21713       PARAMETER (NMXJ=60)
21714       CHARACTER*10 REJTIT
21715       INTEGER IFAIL
21716       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21717
21718       DIMENSION P1(4),P2(4),PD1(-6:6)
21719
21720       PARAMETER ( TINY   =  1.D-10 )
21721
21722       ITRY  = 0
21723       NTRY  = 10
21724       LSC1HD = 0
21725       LSIDX(1) = 1
21726
21727 C  check phase space
21728       IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21729         IFAIL(18) = IFAIL(18)+1
21730         IREJ = 50
21731         RETURN
21732       ENDIF
21733
21734       AS     = (PARMDL(160+II)/ECMP)**2
21735       AH     = (2.D0*PTWANT/ECMP)**2
21736
21737       ALNS   = LOG(AS)
21738       ALNH   = LOG(AH)
21739
21740       XMAX   = MAX(TINY,1.D0-AS)
21741       Z1MAX  = LOG(XMAX)
21742       Z1DIF  = Z1MAX-ALNH
21743 C
21744 C  main loop to select hard and soft parton kinematics
21745 C -----------------------------------------------------
21746  120  CONTINUE
21747         IREJ = 0
21748         ITRY   = ITRY+1
21749         LSC1HD = LSC1HD+1
21750         IF(ITRY.GT.1) THEN
21751           IFAIL(17) = IFAIL(17)+1
21752           IF(ITRY.GE.NTRY) THEN
21753             IREJ = 1
21754             GOTO 450
21755           ENDIF
21756         ENDIF
21757         LINE   = 0
21758         LSCAHD = 0
21759         XSS1   = 0.D0
21760         XSS2   = 0.D0
21761         MSPAR1 = 0
21762         MSPAR2 = 0
21763
21764 C  select hard V,X
21765         CALL PHO_HARSCA(1,II)
21766         XSS1   = XSS1+X1
21767         XSS2   = XSS2+X2
21768 C  debug output
21769         IF(IDEB(25).GE.20) THEN
21770           WRITE(LO,'(1X,A,2E12.4,2I5)')
21771      &      'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21772      &      AS,XMAX,MSPR,ITRY
21773           WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2  SUM X1,2',
21774      &      X1,X2,XSS1,XSS2
21775         ENDIF
21776
21777       IF(MSPR.LE.11) THEN
21778         IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21779       ELSE IF(MSPR.LE.13) THEN
21780         IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21781       ENDIF
21782
21783 C  fill /POHSLT/
21784       LSCAHD     = 1
21785       LSIDX(1)   = 1
21786       XHD(1,1)   = X1
21787       XHD(1,2)   = X2
21788       X0HD(1,1)  = X1
21789       X0HD(1,2)  = X2
21790       VHD(1)     = V
21791       ETAHD(1,1) = ETAC
21792       ETAHD(1,2) = ETAD
21793       PTHD(1)    = PT
21794       Q2SCA(1,1) = QQPD
21795       Q2SCA(1,2) = QQPD
21796       NPROHD(1)  = MSPR
21797       NBRAHD(1,1)= IDPDG1
21798       NBRAHD(1,2)= IDPDG2
21799       DO 45 I=1,4
21800         PPH(I,1)   = PHI1(I)
21801         PPH(I,2)   = PHI2(I)
21802         PPH(4+I,1) = PHO1(I)
21803         PPH(4+I,2) = PHO2(I)
21804  45   CONTINUE
21805 C  valence quarks
21806       IVAL1 = IV1
21807       IVAL2 = IV2
21808       PDFVA(1,1) = 0.D0
21809       PDFVA(1,2) = 0.D0
21810 C  parton flavours
21811       IF(MSPR.LE.11) THEN
21812         NINHD(1,1) = IDPDG1
21813         NINHD(1,2) = IB
21814         PDFVA(1,2) = PDF2(IB)
21815         KHDIR = 1
21816       ELSE IF(MSPR.LE.13) THEN
21817         NINHD(1,1) = IA
21818         PDFVA(1,1) = PDF1(IA)
21819         NINHD(1,2) = IDPDG2
21820         KHDIR = 2
21821       ELSE
21822         NINHD(1,1) = IDPDG1
21823         NINHD(1,2) = IDPDG2
21824         KHDIR = 3
21825       ENDIF
21826       N0INHD(1,1) = NINHD(1,1)
21827       N0INHD(1,2) = NINHD(1,2)
21828       N0IVAL(1,1) = IVAL1
21829       N0IVAL(1,2) = IVAL2
21830       NOUTHD(1,1) = IC
21831       NOUTHD(1,2) = ID
21832
21833 C  reweight according to photon virtuality
21834       IF(MSPR.NE.14) THEN
21835         IF(IPAMDL(115).GE.1) THEN
21836           WGX = 1.D0
21837           IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21838             QQPD = Q2SCA(1,2)
21839             IF(IPAMDL(115).EQ.1) THEN
21840               IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21841                 WGX = 0.D0
21842               ELSE
21843                 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21844      &               /LOG(QQPD/PARMDL(144))
21845               ENDIF
21846               IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21847             ELSE IF(IPAMDL(115).EQ.2) THEN
21848               CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21849               WGX = PD1(IB)/PDFVA(1,2)
21850             ENDIF
21851           ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21852      &            .AND.(IDPDG1.EQ.22)) THEN
21853             QQPD = Q2SCA(1,1)
21854             IF(IPAMDL(115).EQ.1) THEN
21855               IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
21856                 WGX = 0.D0
21857               ELSE
21858                 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
21859      &               /LOG(QQPD/PARMDL(144))
21860               ENDIF
21861               IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
21862             ELSE IF(IPAMDL(115).EQ.2) THEN
21863               CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
21864               WGX = PD1(IA)/PDFVA(1,1)
21865             ENDIF
21866           ENDIF
21867
21868           IF(IDEB(25).GE.25)
21869      &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21870      &        're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21871      &        KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21872
21873           IF(WGX.LT.DT_RNDM(WGX)) THEN
21874             IREJ = 50
21875             RETURN
21876           ENDIF
21877
21878           IF(WGX.GT.1.01D0)
21879      &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21880      &        're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21881      &        KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21882
21883         ENDIF
21884       ENDIF
21885
21886 C  generate ISR
21887       IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
21888         IF(IPAMDL(109).EQ.1) THEN
21889           Q2H = PARMDL(93)*PT**2
21890         ELSE
21891           Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
21892         ENDIF
21893         XHMAX1 =  1.D0 - XSS1 - AS + XHD(1,1)
21894         XHMAX2 =  1.D0 - XSS2 - AS + XHD(1,2)
21895         DO 42 J=1,4
21896           P1(J) = PPH(4+J,1)
21897           P2(J) = PPH(4+J,2)
21898  42     CONTINUE
21899         CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
21900      &    N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
21901      &    XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
21902         XSS1 = XSS1+XISR1-XHD(1,1)
21903         XSS2 = XSS2+XISR2-XHD(1,2)
21904         NINHD(1,1) = IFL1
21905         NINHD(1,2) = IFL2
21906         XHD(1,1) = XISR1
21907         XHD(1,2) = XISR2
21908       ELSE
21909         IFL1 = NINHD(1,1)
21910         IFL2 = NINHD(1,2)
21911       ENDIF
21912       NIVAL(1,1) = IVAL1
21913       NIVAL(1,2) = IVAL2
21914
21915 C  add photon/hadron remnant
21916
21917 C  incoming gluon
21918       IF(IFL2.EQ.0) THEN
21919         XMAXX    = 1.D0 - XSS2 - AS
21920         XMAXH    = MIN(XMAXX,PARMDL(44))
21921         CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21922         IVAL2 = 1
21923         MSPAR1 = 0
21924         MSPAR2 = 2
21925         MHPAR1 = 1
21926         MHPAR2 = 1
21927       ELSE IF(IFL1.EQ.0) THEN
21928         XMAXX    = 1.D0 - XSS1 - AS
21929         XMAXH    = MIN(XMAXX,PARMDL(44))
21930         CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21931         IVAL1 = 1
21932         MSPAR1 = 2
21933         MSPAR2 = 0
21934         MHPAR1 = 1
21935         MHPAR2 = 1
21936
21937 C  incoming quark
21938       ELSE IF(ABS(IFL2).LE.12) THEN
21939         IF(IVAL2.EQ.1) THEN
21940           XS2(1) = 1.D0 - XSS2
21941           MSPAR1 = 0
21942           MSPAR2 = 1
21943           MHPAR1 = 1
21944           MHPAR2 = 1
21945         ELSE
21946           XMAXX    = 1.D0 - XSS2 - AS
21947           XMAXH    = MIN(XMAXX,PARMDL(44))
21948           CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21949           MSPAR1 = 0
21950           MSPAR2 = 3
21951           MHPAR1 = 1
21952           MHPAR2 = 1
21953         ENDIF
21954       ELSE IF(ABS(IFL1).LE.12) THEN
21955         IF(IVAL1.EQ.1) THEN
21956           XS1(1) = 1.D0 - XSS1
21957           MSPAR1 = 1
21958           MSPAR2 = 0
21959           MHPAR1 = 1
21960           MHPAR2 = 1
21961         ELSE
21962           XMAXX    = 1.D0 - XSS1 - AS
21963           XMAXH    = MIN(XMAXX,PARMDL(44))
21964           CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21965           MSPAR1 = 3
21966           MSPAR2 = 0
21967           MHPAR1 = 1
21968           MHPAR2 = 1
21969         ENDIF
21970
21971 C  double direct process
21972       ELSE IF(MSPR.EQ.14) THEN
21973         MSPAR1 = 0
21974         MSPAR2 = 0
21975         MHPAR1 = 1
21976         MHPAR2 = 1
21977
21978 C  unknown process
21979       ELSE
21980         WRITE(LO,'(/1X,A,I3/)')
21981      &    'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
21982         CALL PHO_ABORT
21983       ENDIF
21984
21985       IF(IREJ.NE.0) THEN
21986         IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
21987      &    'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
21988         GOTO 120
21989       ENDIF
21990
21991 C  soft particle momenta
21992       IF(MSPAR1.GT.0) THEN
21993         DO 50 I=1,MSPAR1
21994           PSOFT1(1,I) = 0.D0
21995           PSOFT1(2,I) = 0.D0
21996           PSOFT1(3,I) = XS1(I)*ECMP/2.D0
21997           PSOFT1(4,I) = XS1(I)*ECMP/2.D0
21998  50     CONTINUE
21999       ENDIF
22000       IF(MSPAR2.GT.0) THEN
22001         DO 55 I=1,MSPAR2
22002           PSOFT2(1,I) = 0.D0
22003           PSOFT2(2,I) = 0.D0
22004           PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22005           PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22006  55     CONTINUE
22007       ENDIF
22008 C  process counting
22009       MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
22010       KSOFT = MAX(MSPAR1,MSPAR2)
22011       KHARD = MAX(MHPAR1,MHPAR2)
22012 C  debug output
22013       IF(IDEB(25).GE.10) THEN
22014         WRITE(LO,'(/1X,A,2I3,3I5)')
22015      &    'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
22016      &     IVAL1,IVAL2,MSPR,ITRY,NTRY
22017         IF(MSPAR1.GT.0) THEN
22018           WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
22019           DO 105 I=1,MSPAR1
22020             WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
22021  105      CONTINUE
22022         ENDIF
22023         IF(MSPAR2.GT.0) THEN
22024           WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
22025           DO 106 I=1,MSPAR2
22026             WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
22027  106      CONTINUE
22028         ENDIF
22029         WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
22030         WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
22031         WRITE(LO,'(5X,A,I4)') 'fin.hard momenta  particle 1:',MHPAR1
22032         WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
22033         WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
22034         WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
22035         WRITE(LO,'(5X,A,I4)') 'fin.hard momenta  particle 2:',MHPAR2
22036         WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
22037       ENDIF
22038       RETURN
22039
22040  450  CONTINUE
22041       IFAIL(16) = IFAIL(16)+1
22042       IF(IDEB(25).GE.2) THEN
22043         WRITE(LO,'(1X,A,3I5)')
22044      &    'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
22045        WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
22046        IF(IDEB(25).GE.5) THEN
22047          CALL PHO_PREVNT(0)
22048        ELSE
22049          CALL PHO_PREVNT(-1)
22050        ENDIF
22051       ENDIF
22052
22053       END
22054
22055 CDECK  ID>, PHO_POMSCA
22056       SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
22057      &                     MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
22058 C**********************************************************************
22059 C
22060 C     parton orientated formulation of soft and hard inelastic events
22061 C
22062 C
22063 C     input:    II        particle combiantion (1..4)
22064 C               MSPOM     number of soft pomerons
22065 C               MHPOM     number of semihard pomerons
22066 C               MSREG     number of soft reggeons
22067 C
22068 C     output:   IVAL1,2   0 no valence quark engaged
22069 C                         otherwise:  position of valence quark engaged
22070 C                         neg.number: gluon connected to valence quark
22071 C                                     by color flow
22072 C               MSPAR1,2  number of realized soft partons
22073 C               MHPAR1,2  number of realized hard partons
22074 C               IREJ      1 failure
22075 C                         0 success
22076 C
22077 C**********************************************************************
22078       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22079       SAVE
22080
22081       PARAMETER (TINY   =  1.D-30 )
22082
22083 C  input/output channels
22084       INTEGER LI,LO
22085       COMMON /POINOU/ LI,LO
22086 C  event debugging information
22087       INTEGER NMAXD
22088       PARAMETER (NMAXD=100)
22089       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22090      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22091       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22092      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22093 C  model switches and parameters
22094       CHARACTER*8 MDLNA
22095       INTEGER ISWMDL,IPAMDL
22096       DOUBLE PRECISION PARMDL
22097       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22098 C  general process information
22099       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22100       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22101 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
22102       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22103       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22104       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22105      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22106 C  event weights and generated cross section
22107       INTEGER IPOWGC,ISWCUT,IVWGHT
22108       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22109       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22110      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22111 C  hard cross sections and MC selection weights
22112       INTEGER Max_pro_2
22113       PARAMETER ( Max_pro_2 = 16 )
22114       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22115      &  MH_acc_1,MH_acc_2
22116       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22117       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22118      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22119      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22120      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22121      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22122 C  hard scattering parameters used for most recent hard interaction
22123       INTEGER NFbeta,NF
22124       DOUBLE PRECISION ALQCD2,BQCD
22125       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22126 C  data of c.m. system of Pomeron / Reggeon exchange
22127       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22128       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22129      &                 SIDP,CODP,SIFP,COFP
22130       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22131      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
22132      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
22133 C  obsolete cut-off information
22134       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22135       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22136 C  some hadron information, will be deleted in future versions
22137       INTEGER NFS
22138       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22139       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22140 C  data on most recent hard scattering
22141       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22142       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22143      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22144      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22145       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22146      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22147      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22148      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22149      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22150 C  light-cone x fractions and c.m. momenta of soft cut string ends
22151       INTEGER MAXSOF
22152       PARAMETER ( MAXSOF = 50 )
22153       INTEGER IJSI2,IJSI1
22154       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22155       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22156      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22157      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
22158 C  hard scattering data
22159       INTEGER MSCAHD
22160       PARAMETER ( MSCAHD = 50 )
22161       INTEGER LSCAHD,LSC1HD,LSIDX,
22162      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22163       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22164       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22165      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22166      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22167      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22168      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22169      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22170      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22171 C  table of particle indices for recursive PHOJET calls
22172       INTEGER MAXIPX
22173       PARAMETER ( MAXIPX = 100 )
22174       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22175       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22176      &                IPOIX1,IPOIX2,IPOIX3
22177 C  internal rejection counters
22178       INTEGER NMXJ
22179       PARAMETER (NMXJ=60)
22180       CHARACTER*10 REJTIT
22181       INTEGER IFAIL
22182       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22183
22184       DIMENSION P1(4),P2(4),PD1(-6:6)
22185
22186       IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22187      &  'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22188
22189       ITRY  = 0
22190       NTRY  = 10
22191       IREJ  = 0
22192       INMAX = 10
22193       MHARD = MHPOM
22194
22195 C  phase space limitation (single hard valence-valence quark scattering)
22196       IF(MHPOM.GT.0) THEN
22197         Emin = 2.D0*PTWANT + 0.2D0
22198         IF(ECMP.LT.Emin) THEN
22199           IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22200      &      'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22201           IREJ = 50
22202           IFAIL(6) = IFAIL(6) + 1
22203           RETURN
22204         ENDIF
22205       ENDIF
22206
22207       SAS    = PARMDL(160+II)/ECMP
22208       SAH    = 2.D0*PTWANT/ECMP
22209       AS     = SAS**2
22210       AH     = SAH**2
22211
22212 C  save energy for leading particle effect
22213       XMAXP1 = 1.D0
22214       if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22215       XMAXP2 = 1.D0
22216       if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22217
22218 C
22219 C  main loop to select hard and soft parton kinematics
22220 C -----------------------------------------------------
22221       IFAIL(31) = IFAIL(31)+MHARD
22222  20   CONTINUE
22223         IREJ  = 0
22224         IHARD = 0
22225         LSC1HD = 0
22226         ITRY  = ITRY+1
22227         IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22228         IF(ITRY.GE.NTRY) THEN
22229           IREJ = 1
22230           GOTO 450
22231         ENDIF
22232         LINE   = 0
22233         LSCAHD = 0
22234         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22235           XSS1   = MAX(0.D0,1.D0-XPSUB)
22236           XSS2   = MAX(0.D0,1.D0-XTSUB)
22237         ELSE
22238           XSS1   = 0.D0
22239           XSS2   = 0.D0
22240         ENDIF
22241  22     continue
22242
22243 C  partons needed to construct soft/hard interactions
22244         MSPAR1 = 2*MSPOM+MSREG+MHPOM
22245         MSPAR2 = MSPAR1
22246         MHPAR1 = MHPOM
22247         MHPAR2 = MHPOM
22248
22249 C  number of strings
22250         MSCHA = 2*MSPOM+MSREG
22251         MHCHA = 2*MHPOM
22252
22253         KSOFT = MSCHA
22254         KHARD = MHCHA
22255
22256 C  check actual phase space limit
22257         XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22258         IF(XX.GE.1.D0) THEN
22259           IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22260      &      'PHO_POMSCA: internal kin. rejection ',
22261      &      '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22262      &      MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22263           if(MSPOM+MSREG+MHPOM.gt.1) then
22264             if(MSREG.gt.0) then
22265               MSREG = MSREG-1
22266             else if(MSPOM.gt.0) THEN
22267               MSPOM = MSPOM-1
22268             else if(MHPOM.gt.1) then
22269               MHPOM = MHPOM-1
22270             endif
22271             goto 22
22272           endif
22273           IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22274      &      'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22275           IREJ = 50
22276           IFAIL(6) = IFAIL(6) + 1
22277           RETURN
22278         ENDIF
22279
22280         XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22281         XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22282
22283 C  very low energy phase space restriction
22284         if(MHARD.gt.0) then
22285           if((XMAXX1*XMAXX2.le.AH)) then
22286             IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22287      &        'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22288             IREJ = 50
22289             IFAIL(6) = IFAIL(6) + 1
22290             RETURN
22291           endif
22292         endif
22293
22294         AS = MAX(AS,PSOMIN/PCMP)
22295         ALNS  = LOG(AS)
22296         ALNH  = LOG(AH)
22297         Z1MAX = LOG(XMAXX1)
22298         Z2MAX = LOG(XMAXX2)
22299         Z1DIF = Z1MAX+Z2MAX-ALNH
22300         Z2DIF = Z1DIF
22301         PTMAX = 0.D0
22302 C
22303 C  select hard parton momenta
22304 C ------------------- begin of inner loop -------------------
22305         IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22306
22307         IF(MHARD.GT.MSCAHD) THEN
22308           WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22309      &      'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22310           IREJ = 1
22311           RETURN
22312         ENDIF
22313
22314         DO 11 NN=1,MHARD
22315 C
22316 C  generate one resolved hard scattering
22317 C
22318 C  high-pt option
22319           IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22320             CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22321      &                  -1,Max_pro_2,1,4,MSPOM+MHPOM)
22322             XSCUT = HSig(9)
22323             AHS    = AH
22324             ALNHS  = ALNH
22325             Z1DIFS = Z1DIF
22326             Z2DIFS = Z2DIF
22327             AH    = (2.D0*PTWANT/ECMP)**2
22328             ALNH  = LOG(AH)
22329             Z1DIF = Z1MAX+Z2MAX-ALNH
22330             Z2DIF = Z1DIF
22331             IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22332               IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22333      &          'PHO_POMSCA: kin.rejection, high-pt option ',
22334      &          '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22335               IREJ = 5
22336               RETURN
22337             ENDIF
22338             CALL PHO_HARSCA(2,II)
22339             CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22340      &                  -1,Max_pro_2,1,4,MSPOM+MHPOM)
22341             AH    = AHS
22342             ALNH  = ALNHS
22343             Z1DIF = Z1DIFS
22344             Z2DIF = Z2DIFS
22345             IPOWGC(4+II) = IPOWGC(4+II)+1
22346             HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22347 C  minimum bias option
22348           ELSE
22349             CALL PHO_HARSCA(2,II)
22350           ENDIF
22351
22352 C  fill /POHSLT/
22353           LSIDX(NN)    = NN
22354           LSCAHD       = NN
22355           XHD(NN,1)    = X1
22356           XHD(NN,2)    = X2
22357           X0HD(NN,1)   = X1
22358           X0HD(NN,2)   = X2
22359           VHD(NN)      = V
22360           ETAHD(NN,1)  = ETAC
22361           ETAHD(NN,2)  = ETAD
22362           PTHD(NN)     = PT
22363           NPROHD(NN)   = MSPR
22364           Q2SCA(NN,1)  = QQPD
22365           Q2SCA(NN,2)  = QQPD
22366           PDFVA(NN,1)  = PDF1(IA)
22367           PDFVA(NN,2)  = PDF2(IB)
22368           NINHD(NN,1)  = IA
22369           NINHD(NN,2)  = IB
22370           N0INHD(NN,1) = IA
22371           N0INHD(NN,2) = IB
22372           NIVAL(NN,1)  = IV1
22373           NIVAL(NN,2)  = IV2
22374           N0IVAL(NN,1) = IV1
22375           N0IVAL(NN,2) = IV2
22376           NOUTHD(NN,1) = IC
22377           NOUTHD(NN,2) = ID
22378           NBRAHD(NN,1) = IDPDG1
22379           NBRAHD(NN,2) = IDPDG2
22380           I3 = 8*(NN-1)
22381           I4 = 8*(NN-1)+4
22382           DO 50 I=1,4
22383             PPH(I3+I,1) = PHI1(I)
22384             PPH(I3+I,2) = PHI2(I)
22385             PPH(I4+I,1) = PHO1(I)
22386             PPH(I4+I,2) = PHO2(I)
22387  50       CONTINUE
22388
22389  11     CONTINUE
22390
22391 C  sort according to pt-hat
22392         DO 12 NN=1,MHARD
22393           PTMX = PTHD(LSIDX(NN))
22394           IPTM = NN
22395           DO 13 I=NN+1,MHARD
22396             IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22397               IPTM = I
22398               PTMX = PTHD(LSIDX(I))
22399             ENDIF
22400  13       CONTINUE
22401           IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22402  12     CONTINUE
22403         IPTM = LSIDX(1)
22404
22405 C  copy partons, generate ISR
22406         DO 15 L=1,MHARD
22407           NN = LSIDX(L)
22408           XSSS1  = XSS1+XHD(NN,1)
22409           XSSS2  = XSS2+XHD(NN,2)
22410 C  debug output
22411           IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22412      &      'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22413      &      L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22414 C  check phase space
22415           IF(    (XSSS1.GT.XMAXX1)
22416      &       .OR.(XSSS2.GT.XMAXX2)
22417      &       .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22418             IF(IHARD.EQ.0) THEN
22419               IF(ISWMDL(2).NE.1) GOTO 20
22420               MHPOM = 0
22421               MSPOM = 1
22422               MSREG = 0
22423             ENDIF
22424             GOTO 199
22425           ENDIF
22426
22427 C  reweight according to photon virtuality
22428           IF(IPAMDL(115).GE.1) THEN
22429             QQPD = Q2SCA(NN,1)
22430             WGX = 1.D0
22431             IF(IDPDG1.EQ.22) THEN
22432               IF(IPAMDL(115).EQ.1) THEN
22433                 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22434                   WG1 = 0.D0
22435                 ELSE
22436                   WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22437      &                 /LOG(QQPD/PARMDL(144))
22438                 ENDIF
22439                 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22440               ELSE IF(IPAMDL(115).EQ.2) THEN
22441                 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22442                 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22443               ENDIF
22444               WGX = WG1
22445             ENDIF
22446             QQPD = Q2SCA(NN,2)
22447             IF(IDPDG2.EQ.22) THEN
22448               IF(IPAMDL(115).EQ.1) THEN
22449                 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22450                   WG1 = 0.D0
22451                 ELSE
22452                   WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22453      &                 /LOG(QQPD/PARMDL(144))
22454                 ENDIF
22455                 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22456               ELSE IF(IPAMDL(115).EQ.2) THEN
22457                 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22458                 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22459               ENDIF
22460               WGX = WGX*WG1
22461             ENDIF
22462
22463             IF(IDEB(24).GE.25)
22464      &        WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22465      &          ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22466      &          KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22467
22468             IF(WGX.LT.DT_RNDM(WGX)) THEN
22469               IF(L.EQ.1) THEN
22470                 IREJ = 50
22471                 RETURN
22472               ELSE
22473                 GOTO 199
22474               ENDIF
22475             ENDIF
22476
22477             IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22478      &        'PHO_POMSCA: ',
22479      &        'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22480      &        KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22481
22482           ENDIF
22483
22484 C  generate ISR
22485           IF((ISWMDL(8).GE.2)
22486      &       .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22487             IF(IPAMDL(109).EQ.1) THEN
22488               Q2H = PARMDL(93)*PTHD(NN)**2
22489             ELSE
22490               Q2H = -PARMDL(93)*VHD(NN)
22491      &              *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22492             ENDIF
22493             XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22494             XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22495             I3     = 8*NN-4
22496             DO 42 J=1,4
22497               P1(J) = PPH(I3+J,1)
22498               P2(J) = PPH(I3+J,2)
22499  42         CONTINUE
22500             IF(IDEB(24).GE.10)
22501      &        WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22502      &          'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22503      &          L,NN,XHD(NN,1),XHD(NN,2),Q2H
22504             J = NN
22505             IF(L.EQ.1) J = -NN
22506             CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22507      &        N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22508      &        X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22509      &        NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22510             XSSS1 = XSSS1+XISR1-XHD(NN,1)
22511             XSSS2 = XSSS2+XISR2-XHD(NN,2)
22512             NINHD(NN,1) = IFL1
22513             NINHD(NN,2) = IFL2
22514             XHD(NN,1) = XISR1
22515             XHD(NN,2) = XISR2
22516           ENDIF
22517
22518 C  check phase space
22519           IF(    (XSSS1.GT.XMAXX1)
22520      &       .OR.(XSSS2.GT.XMAXX2)
22521      &       .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22522             IF(IHARD.EQ.0) THEN
22523               IF(ISWMDL(2).NE.1) GOTO 20
22524               MHPOM = 0
22525               MSPOM = 1
22526               MSREG = 0
22527             ENDIF
22528             GOTO 199
22529           ENDIF
22530
22531 C  leave energy for leading particle effect
22532           IF((IHARD.GT.0).AND.
22533      &       ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22534             GOTO 199
22535           endif
22536
22537 C  hard scattering accepted
22538           IHARD = IHARD+1
22539           XSS1 = XSSS1
22540           XSS2 = XSSS2
22541           IFAIL(31) = IFAIL(31)-1
22542
22543  15     CONTINUE
22544
22545 C ------------------- end of inner (hard) loop -------------------
22546  199    CONTINUE
22547
22548         MHPOM =  IHARD
22549         MHPAR1 = IHARD
22550         MHPAR2 = IHARD
22551
22552 C  count valences involved in hard scattering
22553         IVAL1  = 0
22554         IVAL2  = 0
22555         DO 17 L=1,IHARD
22556           NN = LSIDX(L)
22557           IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22558           IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22559  17     CONTINUE
22560
22561         IQUA1  = 0
22562         IQUA2  = 0
22563         IVGLU1 = 0
22564         IVGLU2 = 0
22565         DO 18 L=1,IHARD
22566           NN = LSIDX(L)
22567
22568 C  photon, pomeron valences
22569           IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22570             IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22571               NIVAL(NN,1) = 1
22572               IVAL1 = NN
22573             ENDIF
22574           ENDIF
22575           IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22576             IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22577               NIVAL(NN,2) = 1
22578               IVAL2 = NN
22579             ENDIF
22580           ENDIF
22581
22582 C  total number of quarks
22583           IF(NINHD(NN,1).NE.0) THEN
22584             IQUA1 = IQUA1+1
22585           ELSE IF(IVGLU1.EQ.0) THEN
22586             IVGLU1 = NN
22587           ENDIF
22588           IF(NINHD(NN,2).NE.0) THEN
22589             IQUA2 = IQUA2+1
22590           ELSE IF(IVGLU2.EQ.0) THEN
22591             IVGLU2 = NN
22592           ENDIF
22593  18     CONTINUE
22594
22595 C  gluons emitted by valence quarks
22596         VALPRO = 1.D0
22597         IF(II.EQ.1) VALPRO = VALPRG(1)
22598         IVQ1 = 1
22599         IVG1 = 0
22600         IVAL1 = MAX(IVAL1,0)
22601         IF(IVAL1.EQ.0) THEN
22602           IVQ1 = 0
22603           IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22604             IVAL1 = -IVGLU1
22605             IVG1 = 1
22606           ENDIF
22607         ENDIF
22608         VALPRO = 1.D0
22609         IF(II.EQ.1) VALPRO = VALPRG(2)
22610         IVQ2 = 1
22611         IVG2 = 0
22612         IVAL2 = MAX(IVAL2,0)
22613         IF(IVAL2.EQ.0) THEN
22614           IVQ2 = 0
22615           IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22616             IVAL2 = -IVGLU2
22617             IVG2 = 1
22618           ENDIF
22619         ENDIF
22620         MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22621 C  debug output
22622         IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22623      &    'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22624      &    IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22625
22626 C  select soft X values
22627  25     CONTINUE
22628 C  number of soft/remnant quarks
22629         IF(MSPOM.EQ.0) THEN
22630           IF(IPAMDL(18).EQ.0) THEN
22631             MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22632             MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22633           ELSE
22634             MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22635             MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22636           ENDIF
22637         ELSE
22638           IF(IPAMDL(18).EQ.0) THEN
22639             MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22640             MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22641           ELSE
22642             MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22643             MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22644           ENDIF
22645         ENDIF
22646 C  debug output
22647         IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22648      &    'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22649      &    MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22650
22651         XMAX1  = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22652         XMAX2  = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22653         I1 = IVQ1
22654         I2 = IVQ2
22655         IF(IVAL1.LE.0) I1 = 0
22656         IF(IVAL2.LE.0) I2 = 0
22657         IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22658           MSDIFF = 2*MSPOM
22659         ELSE
22660           MSDIFF = 2*MAX(0,MSPOM-1)
22661         ENDIF
22662         MSG1 = MSPAR1
22663         MSG2 = MSPAR2
22664         MSM1 = MSPAR1-MSDIFF
22665         MSM2 = MSPAR2-MSDIFF
22666         XMAXH1 = MIN(XMAX1,PARMDL(44))
22667         XMAXH2 = MIN(XMAX2,PARMDL(44))
22668         CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22669      &              XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22670
22671 C  correct for proper simulation of high pt tail
22672         IF(IREJ.NE.0) THEN
22673           IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22674      &      'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22675      &      MSPOM,MHPOM,I1,I2
22676           IF(MSPOM*MHPOM.GT.0) THEN
22677             MSPOM = MSPOM-1
22678             GOTO 25
22679           ELSE IF(MSPOM.GT.1) THEN
22680             MSPOM = MSPOM-1
22681             GOTO 25
22682           ELSE IF(MHPOM.GT.1) THEN
22683             IHARD = IHARD-1
22684             IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22685      &         .AND.(IPROCE.EQ.1)) THEN
22686               XSS1   = MAX(0.D0,1.D0-XPSUB)
22687               XSS2   = MAX(0.D0,1.D0-XTSUB)
22688             ELSE
22689               XSS1   = 0.D0
22690               XSS2   = 0.D0
22691             ENDIF
22692             DO 103 K=1,IHARD
22693               I = LSIDX(K)
22694               XSS1 = XSS1+ XHD(I,1)
22695               XSS2 = XSS2+ XHD(I,2)
22696  103        CONTINUE
22697             GOTO 199
22698           ENDIF
22699           IREJ = 4
22700           GOTO 450
22701         ENDIF
22702 C  accepted
22703         MSPOM  = MSPOM-(MSPAR1-MSG1)/2
22704         MSPAR1 = MSG1
22705         MSPAR2 = MSG2
22706 C  ------------ kinematics sampled ---------------
22707 C  debug output
22708         IF(IDEB(24).GE.10) THEN
22709           WRITE(LO,'(1X,A,I3)')
22710      &      'PHO_POMSCA: soft x values, ITRY',ITRY
22711           DO 104 I=2,MAX(MSPAR1,MSPAR2)
22712             WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22713  104      CONTINUE
22714         ENDIF
22715       IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22716
22717 C  end of loop
22718       XS1(1) = 1.D0 - XSS1
22719       XS2(1) = 1.D0 - XSS2
22720
22721 C  process counting
22722       DO 30 N=1,LSCAHD
22723         MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22724  30   CONTINUE
22725
22726 C  soft particle momenta
22727
22728       IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22729         WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22730      &    '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22731         IREJ = 1
22732         RETURN
22733       ENDIF
22734
22735       DO 55 I=1,MSPAR1
22736         PSOFT1(1,I) = 0.D0
22737         PSOFT1(2,I) = 0.D0
22738         PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22739         PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22740  55   CONTINUE
22741       DO 60 I=1,MSPAR2
22742         PSOFT2(1,I) = 0.D0
22743         PSOFT2(2,I) = 0.D0
22744         PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22745         PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22746  60   CONTINUE
22747
22748       KSOFT = MAX(MSPAR1,MSPAR2)
22749       KHARD = MAX(MHPAR1,MHPAR2)
22750       KSPOM = MSPOM
22751       KSREG = MSREG
22752       KHPOM = MHPOM
22753
22754 C  debug output
22755       IF(IDEB(24).GE.10) THEN
22756         WRITE(LO,'(/1X,A,2I3,2I5)')
22757      &    'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22758      &     IVAL1,IVAL2,ITRY,NTRY
22759         IF(MSPAR1+MSPAR2.GT.0) THEN
22760           WRITE(LO,'(5X,A)') 'soft x particle1   particle2:'
22761           XTMP1 = 0.D0
22762           XTMP2 = 0.D0
22763           DO 105 I=1,MAX(MSPAR1,MSPAR2)
22764             IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22765               WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22766               XTMP1 = XTMP1+XS1(I)
22767               XTMP2 = XTMP2+XS2(I)
22768             ELSE IF(I.LE.MSPAR1) THEN
22769               WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22770               XTMP1 = XTMP1+XS1(I)
22771             ELSE IF(I.LE.MSPAR2) THEN
22772               WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22773               XTMP2 = XTMP2+XS2(I)
22774             ENDIF
22775  105      CONTINUE
22776           WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22777         ENDIF
22778         IF(MHPAR1.GT.0) THEN
22779           WRITE(LO,'(5X,A)')
22780      &      'NR  IDX  MSPR hard X / hard X ISR / flavor particle 1,2:'
22781           DO 107 K=1,MHPAR1
22782             I = LSIDX(K)
22783             WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22784      &        K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22785      &        NINHD(I,1),NINHD(I,2)
22786               XTMP1 = XTMP1+XHD(I,1)
22787               XTMP2 = XTMP2+XHD(I,2)
22788  107      CONTINUE
22789           WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22790           WRITE(LO,'(5X,A)') 'hard momenta  particle1:'
22791           DO 108 K=1,MHPAR1
22792             I = LSIDX(K)
22793             I3 = 8*I-4
22794             WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22795      &        NOUTHD(I,1)
22796  108      CONTINUE
22797           WRITE(LO,'(5X,A)') 'hard momenta  particle2:'
22798           DO 110 K=1,MHPAR2
22799             I = LSIDX(K)
22800             I3 = 8*I-4
22801             WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22802      &        NOUTHD(I,2)
22803  110      CONTINUE
22804         ENDIF
22805       ENDIF
22806       RETURN
22807
22808 C  event rejected, print debug information
22809  450  CONTINUE
22810       IFAIL(4) = IFAIL(4)+1
22811       IF(IDEB(24).GE.2) THEN
22812         WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22813      &    'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22814      &    MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22815         WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22816         IF(IDEB(24).GE.5) THEN
22817           CALL PHO_PREVNT(0)
22818         ELSE
22819           CALL PHO_PREVNT(-1)
22820         ENDIF
22821       ENDIF
22822
22823       END
22824
22825 CDECK  ID>, PHO_HARX12
22826       SUBROUTINE PHO_HARX12
22827 C**********************************************************************
22828 C
22829 C     selection of x1 and x2 according to 1/x1*1/x2
22830 C
22831 C**********************************************************************
22832       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22833       SAVE
22834
22835       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22836
22837 C  input/output channels
22838       INTEGER LI,LO
22839       COMMON /POINOU/ LI,LO
22840 C  data on most recent hard scattering
22841       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22842       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22843      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22844      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22845       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22846      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22847      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22848      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22849      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22850
22851 10    CONTINUE
22852         Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22853         Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
22854         IF ( (Z1+Z2).LT.ALNH ) GOTO 10
22855       X1   = EXP(Z1)
22856       X2   = EXP(Z2)
22857       AXX  = AH/(X1*X2)
22858       W    = SQRT(MAX(TINY,1.D0-AXX))
22859       W1   = AXX/(1.D0+W)
22860
22861       END
22862
22863 CDECK  ID>, PHO_HARDX1
22864       SUBROUTINE PHO_HARDX1
22865 C**********************************************************************
22866 C
22867 C     selection of x1 according to 1/x1
22868 C     ( x2 = 1 )
22869 C
22870 C**********************************************************************
22871       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22872       SAVE
22873
22874       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22875
22876 C  input/output channels
22877       INTEGER LI,LO
22878       COMMON /POINOU/ LI,LO
22879 C  data on most recent hard scattering
22880       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22881       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22882      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22883      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22884       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22885      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22886      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22887      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22888      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22889
22890       Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22891       X2   = 1.D0
22892       X1   = EXP(Z1)
22893       AXX  = AH/X1
22894       W    = SQRT(MAX(TINY,1.D0-AXX))
22895       W1   = AXX/(1.D0+W)
22896
22897       END
22898
22899 CDECK  ID>, PHO_HARKIN
22900       SUBROUTINE PHO_HARKIN(IREJ)
22901 C***********************************************************************
22902 C
22903 C     selection of kinematic variables
22904 C     (resolved and direct processes)
22905 C
22906 C***********************************************************************
22907       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22908       SAVE
22909
22910       PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
22911
22912 C  input/output channels
22913       INTEGER LI,LO
22914       COMMON /POINOU/ LI,LO
22915 C  event debugging information
22916       INTEGER NMAXD
22917       PARAMETER (NMAXD=100)
22918       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22919      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22920       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22921      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22922 C  data of c.m. system of Pomeron / Reggeon exchange
22923       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22924       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22925      &                 SIDP,CODP,SIFP,COFP
22926       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22927      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
22928      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
22929 C  data on most recent hard scattering
22930       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22931       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22932      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22933      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22934       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22935      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22936      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22937      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22938      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22939 C  internal cross check information on hard scattering limits
22940       DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
22941       COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
22942
22943       PARAMETER ( Max_pro_2 = 16 )
22944       DIMENSION RM(-1:Max_pro_2)
22945       DATA RM / 3.31D0, 0.0D0,
22946      &          7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
22947      &          0.45D0, 0.89D0, 0.89D0, 0.0D0,  4.776D0,
22948      &          0.615D0,4.776D0,0.615D0,1.0D0,  0.0D0,
22949      &          1.0D0 /
22950
22951       IREJ = 0
22952       M    = MSPR
22953
22954 C------------- resolved processes -----------
22955       IF     ( M.EQ.1 ) THEN
22956 10      CALL PHO_HARX12
22957         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22958         U  =-1.D0-V
22959         R  = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
22960         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22961      &    'PHO_HARKIN:weight error',M
22962         IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
22963         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22964       ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
22965 20      CALL PHO_HARX12
22966         WL = LOG(W1)
22967         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22968         U  =-1.D0-V
22969         R  = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
22970         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22971      &    'PHO_HARKIN:weight error',M
22972         IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
22973         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22974       ELSEIF ( M.EQ.3 ) THEN
22975 30      CALL PHO_HARX12
22976         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22977         U  =-1.D0-V
22978         R  = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
22979         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22980      &    'PHO_HARKIN:weight error',M
22981         IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
22982       ELSEIF ( M.EQ.5 ) THEN
22983 50      CALL PHO_HARX12
22984         V  =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22985         U  =-1.D0-V
22986         R  = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
22987         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22988      &    'PHO_HARKIN:weight error',M
22989         IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
22990       ELSEIF ( M.EQ.6 ) THEN
22991 60      CALL PHO_HARX12
22992         V  =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
22993         U  =-1.D0-V
22994         R  = (4.D0/9.D0)*(U*U+V*V)*AXX
22995         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22996      &    'PHO_HARKIN:weight error',M
22997         IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
22998       ELSEIF ( M.EQ.7 ) THEN
22999 70      CALL PHO_HARX12
23000         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23001         U  =-1.D0-V
23002         R  = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
23003      &       -(4.D0/27.D0)*V/U)
23004         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23005      &    'PHO_HARKIN:weight error',M
23006         IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
23007         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23008       ELSEIF ( M.EQ.8 ) THEN
23009 80      CALL PHO_HARX12
23010         V  =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
23011         U  =-1.D0-V
23012         R  = (4.D0/9.D0)*(1.D0+U*U)
23013         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23014      &    'PHO_HARKIN:weight error',M
23015         IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
23016       ELSEIF ( M.EQ.-1 ) THEN
23017 90      CALL PHO_HARX12
23018         WL = LOG(W1)
23019         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23020         U  =-1.D0-V
23021         R  = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
23022         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23023      &    'PHO_HARKIN:weight error',M
23024         IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
23025 C------------- direct / single-resolved processes -----------
23026       ELSEIF ( M.EQ.10 ) THEN
23027 100     CALL PHO_HARDX1
23028         WL = LOG(AXX/(1.D0+W)**2)
23029         U  =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
23030         R  = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
23031         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23032      &    'PHO_HARKIN:weight error',M
23033         IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
23034         V  =-1.D0-U
23035         X2 = X1
23036         X1 = 1.D0
23037       ELSEIF ( M.EQ.11) THEN
23038 110     CALL PHO_HARDX1
23039         WL = LOG(W1)
23040         U  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23041         V  =-1.D0-U
23042         R  = (U*U+V*V)/V*WL*AXX
23043         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23044      &    'PHO_HARKIN:weight error',M
23045         IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
23046         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23047         X2 = X1
23048         X1 = 1.D0
23049       ELSEIF ( M.EQ.12 ) THEN
23050 120     CALL PHO_HARDX1
23051         WL = LOG(AXX/(1.D0+W)**2)
23052         V  =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
23053         R  = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
23054         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23055      &    'PHO_HARKIN:weight error',M
23056         IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
23057       ELSEIF ( M.EQ.13) THEN
23058 130     CALL PHO_HARDX1
23059         WL = LOG(W1)
23060         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23061         U  =-1.D0-V
23062         R  = (U*U+V*V)/U*WL*AXX
23063         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23064      &    'PHO_HARKIN:weight error',M
23065         IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
23066         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23067 C------------- (double) direct process -----------
23068       ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
23069         X1 = 1.D0
23070         X2 = 1.D0
23071         AXX= AH
23072         W  = SQRT(MAX(TINY,1.D0-AXX))
23073         W1 = AXX/(1.D0+W)
23074         WL = LOG(W1)
23075  140    V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23076         U  =-1.D0-V
23077         R  = -(U*U+V*V)/U
23078         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23079      &    'PHO_HARKIN:weight error',M
23080         IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
23081         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23082 C---------------------------------------------
23083       ELSE
23084         WRITE(LO,'(/1X,A,I3)')
23085      &    'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
23086         CALL PHO_ABORT
23087       ENDIF
23088
23089       V    = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23090       U    = -1.D0-V
23091       U    = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23092       PT   = SQRT(U*V*X1*X2)*ECMP
23093       ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23094       ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23095
23096 ***************************************************************
23097       MM = M
23098       IF(M.EQ.-1) MM = 3
23099       ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23100       ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23101       ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23102       ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23103       XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23104       XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23105       XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23106       XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23107 ***************************************************************
23108
23109       IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23110      &  'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23111
23112       END
23113
23114 CDECK  ID>, PHO_HARWGH
23115       SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23116 C***********************************************************************
23117 C
23118 C     calculate product of PDFs and coupling constants
23119 C     according to selected MSPR (process type)
23120 C
23121 C     input:    /POCKIN/
23122 C
23123 C     output:   PDS     resulting from PDFs alone
23124 C               FDISTR  complete weight function
23125 C               PDA,PDB fields containing the PDFs
23126 C
23127 C***********************************************************************
23128       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23129       SAVE
23130
23131       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23132
23133 C  input/output channels
23134       INTEGER LI,LO
23135       COMMON /POINOU/ LI,LO
23136 C  event debugging information
23137       INTEGER NMAXD
23138       PARAMETER (NMAXD=100)
23139       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23140      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23141       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23142      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23143 C  model switches and parameters
23144       CHARACTER*8 MDLNA
23145       INTEGER ISWMDL,IPAMDL
23146       DOUBLE PRECISION PARMDL
23147       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23148 C  data of c.m. system of Pomeron / Reggeon exchange
23149       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23150       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23151      &                 SIDP,CODP,SIFP,COFP
23152       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23153      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23154      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23155 C  currently activated parton density parametrizations
23156       CHARACTER*8 PDFNAM
23157       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23158       DOUBLE PRECISION PDFLAM,PDFQ2M
23159       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23160      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23161 C  hard scattering parameters used for most recent hard interaction
23162       INTEGER NFbeta,NF
23163       DOUBLE PRECISION ALQCD2,BQCD
23164       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23165 C  some hadron information, will be deleted in future versions
23166       INTEGER NFS
23167       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23168       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23169 C  scale parameters for parton model calculations
23170       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23171       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23172       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23173      &                NQQAL,NQQALI,NQQALF,NQQPD
23174 C  data on most recent hard scattering
23175       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23176       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23177      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23178      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23179       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23180      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23181      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23182      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23183      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23184 C  hard cross sections and MC selection weights
23185       INTEGER Max_pro_2
23186       PARAMETER ( Max_pro_2 = 16 )
23187       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23188      &  MH_acc_1,MH_acc_2
23189       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23190       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23191      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23192      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23193      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23194      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23195 C  some constants
23196       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23197       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23198      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23199
23200       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23201       DIMENSION PDA(-6:6),PDB(-6:6)
23202
23203       FDISTR = 0.D0
23204 C  set hard scale  QQ  for alpha and partondistr.
23205       IF     ( NQQAL.EQ.1 ) THEN
23206         QQAL = AQQAL*PT*PT
23207       ELSEIF ( NQQAL.EQ.2 ) THEN
23208         QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23209       ELSEIF ( NQQAL.EQ.3 ) THEN
23210         QQAL = AQQAL*X1*X2*ECMP*ECMP
23211       ELSEIF ( NQQAL.EQ.4 ) THEN
23212         QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23213       ENDIF
23214       IF     ( NQQPD.EQ.1 ) THEN
23215         QQPD = AQQPD*PT*PT
23216       ELSEIF ( NQQPD.EQ.2 ) THEN
23217         QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23218       ELSEIF ( NQQPD.EQ.3 ) THEN
23219         QQPD = AQQPD*X1*X2*ECMP*ECMP
23220       ELSEIF ( NQQPD.EQ.4 ) THEN
23221         QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23222       ENDIF
23223 C  coupling constants, PDFs
23224       IF(MSPR.LT.9) THEN
23225         ALPHA1 = PHO_ALPHAS(QQAL,3)
23226         ALPHA2 = ALPHA1
23227         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23228         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23229         IF ( MSPR.EQ.1  .OR.  MSPR.EQ.4 ) THEN
23230           PDS   = PDA(0)*PDB(0)
23231         ELSE
23232           S2    = 0.D0
23233           S3    = 0.D0
23234           S4    = 0.D0
23235           S5    = 0.D0
23236           DO 10 I=1,NF
23237             S2  = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23238             S3  = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23239             S4  = S4+PDA(I)+PDA(-I)
23240             S5  = S5+PDB(I)+PDB(-I)
23241  10       CONTINUE
23242           IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23243             PDS = S2
23244           ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23245             PDS = PDA(0)*S5+PDB(0)*S4
23246           ELSE IF(MSPR.EQ.7) THEN
23247             PDS = S3
23248           ELSE IF(MSPR.EQ.8) THEN
23249             PDS = S4*S5-(S2+S3)
23250           ENDIF
23251         ENDIF
23252       ELSE IF(MSPR.LT.12) THEN
23253         ALPHA2 = PHO_ALPHAS(QQAL,2)
23254         IF(IDPDG1.EQ.22) THEN
23255           ALPHA1 = pho_alphae(QQAL)
23256         ELSE IF(IDPDG1.EQ.990) THEN
23257           ALPHA1 = PARMDL(74)
23258         ENDIF
23259         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23260         S4    = 0.D0
23261         S6    = 0.D0
23262         DO 15 I=1,NF
23263           S4  = S4+PDB(I)+PDB(-I)
23264 C  charge counting
23265 *         IF(MOD(I,2).EQ.0) THEN
23266 *           S6  = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23267 *         ELSE
23268 *           S6  = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23269 *         ENDIF
23270           S6  = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23271  15     CONTINUE
23272         IF(MSPR.EQ.10) THEN
23273           IF(IDPDG1.EQ.990) THEN
23274             PDS = S4
23275           ELSE
23276             PDS = S6
23277           ENDIF
23278         ELSE
23279           PDS = PDB(0)
23280         ENDIF
23281       ELSE IF(MSPR.LT.14) THEN
23282         ALPHA1 = PHO_ALPHAS(QQAL,1)
23283         IF(IDPDG2.EQ.22) THEN
23284           ALPHA2 = pho_alphae(QQAL)
23285         ELSE IF(IDPDG2.EQ.990) THEN
23286           ALPHA2 = PARMDL(74)
23287         ENDIF
23288         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23289         S4    = 0.D0
23290         S6    = 0.D0
23291         DO 20 I=1,NF
23292           S4  = S4+PDA(I)+PDA(-I)
23293 C  charge counting
23294 *         IF(MOD(I,2).EQ.0) THEN
23295 *           S6  = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23296 *         ELSE
23297 *           S6  = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23298 *         ENDIF
23299           S6  = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23300  20     CONTINUE
23301         IF(MSPR.EQ.12) THEN
23302           IF(IDPDG2.EQ.990) THEN
23303             PDS = S4
23304           ELSE
23305             PDS = S6
23306           ENDIF
23307         ELSE
23308           PDS = PDA(0)
23309         ENDIF
23310       ELSE IF(MSPR.EQ.14) THEN
23311         SSR = X1*X2*ECMP*ECMP
23312         IF(IDPDG1.EQ.22) THEN
23313           ALPHA1 = pho_alphae(SSR)
23314         ELSE IF(IDPDG1.EQ.990) THEN
23315           ALPHA1 = PARMDL(74)
23316         ENDIF
23317         IF(IDPDG2.EQ.22) THEN
23318           ALPHA2 = pho_alphae(SSR)
23319         ELSE IF(IDPDG2.EQ.990) THEN
23320           ALPHA2 = PARMDL(74)
23321         ENDIF
23322         PDS = 1.D0
23323       ELSE
23324         WRITE(LO,'(/1X,A,I4)')
23325      &    'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23326         CALL PHO_ABORT
23327       ENDIF
23328
23329 C  complete weight
23330       FDISTR  = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23331
23332 C  debug output
23333       IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23334      &    'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23335      &    MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23336
23337       END
23338
23339 CDECK  ID>, PHO_HARSCA
23340       SUBROUTINE PHO_HARSCA(IMODE,IP)
23341 C***********************************************************************
23342 C
23343 C     PHO_HARSCA determines the type of hard subprocess, the partons
23344 C     taking part in this subprocess and the kinematic variables
23345 C
23346 C     input:  IMODE   1   direct processes
23347 C                     2   resolved processes
23348 C                     -1  initialization
23349 C                     -2  output of statistics
23350 C             IP      1-4 particle combination (hadron/photon)
23351 C
23352 C***********************************************************************
23353       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23354       SAVE
23355
23356       PARAMETER( EPS  = 1.D-10,
23357      &           DEPS = 1.D-30 )
23358
23359 C  input/output channels
23360       INTEGER LI,LO
23361       COMMON /POINOU/ LI,LO
23362 C  event debugging information
23363       INTEGER NMAXD
23364       PARAMETER (NMAXD=100)
23365       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23366      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23367       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23368      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23369 C  model switches and parameters
23370       CHARACTER*8 MDLNA
23371       INTEGER ISWMDL,IPAMDL
23372       DOUBLE PRECISION PARMDL
23373       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23374 C  internal rejection counters
23375       INTEGER NMXJ
23376       PARAMETER (NMXJ=60)
23377       CHARACTER*10 REJTIT
23378       INTEGER IFAIL
23379       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23380 C  hard scattering parameters used for most recent hard interaction
23381       INTEGER NFbeta,NF
23382       DOUBLE PRECISION ALQCD2,BQCD
23383       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23384 C  data of c.m. system of Pomeron / Reggeon exchange
23385       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23386       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23387      &                 SIDP,CODP,SIFP,COFP
23388       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23389      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23390      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23391 C  names of hard scattering processes
23392       INTEGER Max_pro_1
23393       PARAMETER ( Max_pro_1 = 16 )
23394       CHARACTER*18 PROC
23395       COMMON /POHPRO/ PROC(0:Max_pro_1)
23396 C  data on most recent hard scattering
23397       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23398       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23399      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23400      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23401       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23402      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23403      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23404      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23405      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23406 C  hard scattering data
23407       INTEGER MSCAHD
23408       PARAMETER ( MSCAHD = 50 )
23409       INTEGER LSCAHD,LSC1HD,LSIDX,
23410      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23411       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23412       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23413      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23414      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23415      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23416      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23417      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23418      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23419 C  hard cross sections and MC selection weights
23420       INTEGER Max_pro_2
23421       PARAMETER ( Max_pro_2 = 16 )
23422       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23423      &  MH_acc_1,MH_acc_2
23424       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23425       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23426      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23427      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23428      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23429      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23430 C  cross sections
23431       INTEGER IPFIL,IFAFIL,IFBFIL
23432       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23433      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23434      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23435      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23436      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23437       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23438      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23439      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23440      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23441      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23442      &                IPFIL,IFAFIL,IFBFIL
23443 C  some constants
23444       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23445       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23446      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23447
23448  111  CONTINUE
23449
23450 C  resolved processes
23451       IF(IMODE.EQ.2) THEN
23452
23453         MH_pro_on(0,IP) = 0
23454         HWgx(9)  = 0.D0
23455         DO 15 M=-1,8
23456           IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23457  15     CONTINUE
23458         IF(HWgx(9).LT.DEPS) THEN
23459           WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23460      &      'no resolved process possible for IP',IP,HWgx(9)
23461           CALL PHO_ABORT
23462         ENDIF
23463 C
23464 C ----------------------------------------------I
23465 C  begin of iteration loop (resolved processes) I
23466 C                                               I
23467         IREJSC = 0
23468  10     CONTINUE
23469         IREJSC = IREJSC+1
23470         IF(IREJSC.GT.1000) THEN
23471           WRITE(LO,'(/1X,A,I10)')
23472      &      'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23473             CALL PHO_ABORT
23474         ENDIF
23475
23476 C  find subprocess
23477         B      = DT_RNDM(X1)*HWgx(9)
23478         MSPR   =-2
23479         SUM    = 0.D0
23480  20     MSPR   = MSPR+1
23481         IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23482         IF ( SUM.LT.B  .AND. MSPR.LT.8 ) GOTO 20
23483
23484         IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23485      &    'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23486
23487 C  find kin. variables X1,X2 and V
23488         CALL PHO_HARKIN(IREJ)
23489         IF(IREJ.NE.0) THEN
23490           IFAIL(29) = IFAIL(29)+1
23491           GOTO 10
23492         ENDIF
23493 C  calculate remaining distribution
23494         CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23495 C  actualize counter for cross-section calculation
23496         if(F.LE.1.D-15) then
23497           F = 0.D0
23498           goto 10
23499         endif
23500 *       XSECT(5,MSPR) = XSECT(5,MSPR)+F
23501 *       XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23502         MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23503 C  check F against FMAX
23504         WEIGHT = F/(HWgx(MSPR)+DEPS)
23505         IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23506 C-------------------------------------------------------------------
23507         IF(WEIGHT.GT.1.D0) THEN
23508           WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23509  1234     FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23510      &      2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23511           WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23512      &      ECMP,PTWANT,AS,AH,PT
23513           WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23514      &      ETAC,ETAD,X1,X2,V
23515           CALL PHO_PREVNT(-1)
23516         ENDIF
23517 C-------------------------------------------------------------------
23518 C                                             I
23519 C  end of iteration loop (resolved processes) I
23520 C --------------------------------------------I
23521 C
23522 C*********************************************************************
23523 C
23524 C  direct processes
23525
23526       ELSE IF(IMODE.EQ.1) THEN
23527
23528 C  single-resolved processes kinematically forbidden
23529         if(Z1DIF.lt.0.D0) then
23530           HWgx(10) = 0.D0
23531           HWgx(11) = 0.D0
23532           HWgx(12) = 0.D0
23533           HWgx(13) = 0.D0
23534         endif
23535
23536         HWgx(15)  = 0.D0
23537         if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23538           DO M= 10,14
23539             IF(MH_pro_on(M,IP).EQ.1) then
23540               if((M.eq.10).or.(M.eq.11)) then
23541                 fac = FSUH(1)*FSUP(2)
23542               else if((M.eq.12).or.(M.eq.13)) then
23543                 fac = FSUP(1)*FSUH(2)
23544               else
23545                 fac = FSUH(1)*FSUH(2)
23546               endif
23547               HWgx(15) = HWgx(15)+HWgx(M)*fac
23548             endif
23549           ENDDO
23550         else
23551           DO M= 10,14
23552             IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23553           ENDDO
23554         endif
23555         IF(HWgx(15).LT.DEPS) THEN
23556           WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23557      &      'no direct/single-resolved process possible (IP)',IP
23558           CALL PHO_ABORT
23559         ENDIF
23560 C
23561 C ----------------------------------------------I
23562 C  begin of iteration loop (direct processes)   I
23563 C                                               I
23564         IREJSC = 0
23565  100    CONTINUE
23566         IREJSC = IREJSC+1
23567         IF(IREJSC.GT.1000) THEN
23568           WRITE(LO,'(/1X,A,I10)')
23569      &      'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23570             CALL PHO_ABORT
23571         ENDIF
23572
23573 C  find subprocess
23574         B      = DT_RNDM(X1)*HWgx(15)
23575         MSPR   = 9
23576         SUM    = 0.D0
23577         if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23578  150      continue
23579             MSPR   = MSPR+1
23580             IF(MH_pro_on(MSPR,IP).EQ.1) then
23581               if((MSPR.eq.10).or.(MSPR.eq.11)) then
23582                 fac = FSUH(1)*FSUP(2)
23583               else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23584                 fac = FSUP(1)*FSUH(2)
23585               else
23586                 fac = FSUH(1)*FSUH(2)
23587               endif
23588               SUM = SUM+HWgx(MSPR)*fac
23589             endif
23590           IF ( SUM.LT.B  .AND. MSPR.LT.14 ) GOTO 150
23591         else
23592  200      continue
23593             MSPR   = MSPR+1
23594             IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23595           IF ( SUM.LT.B  .AND. MSPR.LT.14 ) GOTO 200
23596         endif
23597
23598         IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23599      &    'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23600
23601 C  find kin. variables X1,X2 and V
23602         CALL PHO_HARKIN(IREJ)
23603         IF(IREJ.NE.0) THEN
23604           IFAIL(28) = IFAIL(28)+1
23605           GOTO 100
23606         ENDIF
23607
23608 C  calculate remaining distribution
23609         CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23610
23611 C  counter for cross-section calculation
23612         if(F.LE.1.D-15) then
23613           F=0.D0
23614           goto 100
23615         endif
23616 *       XSECT(5,MSPR) = XSECT(5,MSPR)+F
23617 *       XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23618         MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23619 C  check F against FMAX
23620         WEIGHT = F/(HWgx(MSPR)+DEPS)
23621         IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23622 C-------------------------------------------------------------------
23623         IF(WEIGHT.GT.1.D0) THEN
23624           WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23625  1235     FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23626      &      2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23627           WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23628      &      ECMP,PTWANT,AS,AH,PT
23629           WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23630      &      ETAC,ETAD,X1,X2,V
23631           CALL PHO_PREVNT(-1)
23632         ENDIF
23633 C-------------------------------------------------------------------
23634 C                                             I
23635 C  end of iteration loop (direct processes)   I
23636 C --------------------------------------------I
23637
23638       ELSE IF(IMODE.EQ.-1) THEN
23639
23640 C  initialize cross section calculations
23641
23642         DO 40 M=-1,Max_pro_2
23643 *         DO 30 I=5,6
23644 *           XSECT(I,M) = 0.D0
23645 *30       CONTINUE
23646 C  reset counters
23647           DO 35 J=1,4
23648             MH_tried(M,J) = 0
23649             MH_acc_1(M,J) = 0
23650             MH_acc_2(M,J) = 0
23651  35       CONTINUE
23652  40     CONTINUE
23653         IF(IDEB(78).GE.0) THEN
23654 C *** Commented by Chiara
23655 C          WRITE(LO,'(/1X,A,/1X,A)')
23656 C     &      'PHO_HARSCA: activated hard processes',
23657 C     &      '------------------------------------'
23658 C          WRITE(LO,'(5X,A)') 'PROCESS,    IP= 1 ... 4 (on/off)'
23659           DO 42 M=1,Max_pro_2
23660 C            WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23661 C     &        (MH_pro_on(M,J),J=1,4)
23662  42       CONTINUE
23663         ENDIF
23664         RETURN
23665
23666       ELSE IF(IMODE.EQ.-2) THEN
23667
23668 C  calculation of process statistics
23669
23670         do K=1,4
23671
23672           MH_tried(0,K)  = 0
23673           MH_acc_1(0,K)  = 0
23674           MH_acc_2(0,K)  = 0
23675           MH_tried(9,K)  = 0
23676           MH_acc_1(9,K)  = 0
23677           MH_acc_2(9,K)  = 0
23678           MH_tried(15,K) = 0
23679           MH_acc_1(15,K) = 0
23680           MH_acc_2(15,K) = 0
23681
23682           MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23683           MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23684           MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23685
23686           do M=1,8
23687             MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23688             MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23689             MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23690           enddo
23691           do M=10,14
23692             MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23693             MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23694             MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23695           enddo
23696           MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23697           MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23698           MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23699         enddo
23700
23701         IF(IDEB(78).GE.1) THEN
23702           WRITE(LO,'(/1X,A,/1X,A)')
23703      &      'PHO_HARSCA: internal rejection statistics',
23704      &      '-----------------------------------------'
23705           do K=1,4
23706             IF(MH_tried(0,K).GT.0) THEN
23707               WRITE(LO,'(5X,A,I3)')
23708      &          'process (sampled/accepted) for IP:',K
23709               do M=0,Max_pro_2
23710                 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23711      &            MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23712      &            dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23713               enddo
23714             ENDIF
23715           enddo
23716         ENDIF
23717         RETURN
23718
23719       ELSE
23720         WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23721      &    'unsupported mode',IMODE
23722         CALL PHO_ABORT
23723       ENDIF
23724
23725 C  the event is accepted now
23726 C  actualize counter for accepted events
23727       MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23728       IF(MSPR.EQ.-1) MSPR = 3
23729 C
23730 C  find flavor of initial partons
23731 C
23732       SUM    = 0.D0
23733       SCHECK = DT_RNDM(SUM)*PDS-EPS
23734       IF     ( MSPR.EQ.1  .OR.  MSPR.EQ.4 ) THEN
23735         IA = 0
23736         IB = 0
23737       ELSEIF ( MSPR.EQ.2  .OR.  MSPR.EQ.5  .OR.  MSPR.EQ.6 ) THEN
23738         DO 610 IA=-NF,NF
23739           IF ( IA.EQ.0 ) GOTO 610
23740           SUM  = SUM+PDF1(IA)*PDF2(-IA)
23741           IF ( SUM.GE.SCHECK ) GOTO 620
23742  610      CONTINUE
23743  620    IB =-IA
23744       ELSEIF ( MSPR.EQ.3 ) THEN
23745         IB     = 0
23746         DO 630 IA=-NF,NF
23747           IF ( IA.EQ.0 ) GOTO 630
23748           SUM  = SUM+PDF1(0)*PDF2(IA)
23749           IF ( SUM.GE.SCHECK ) GOTO 640
23750           SUM  = SUM+PDF1(IA)*PDF2(0)
23751           IF ( SUM.GE.SCHECK ) GOTO 650
23752  630    CONTINUE
23753  640    IB     = IA
23754         IA     = 0
23755  650    CONTINUE
23756       ELSEIF ( MSPR.EQ.7 ) THEN
23757         DO 660 IA=-NF,NF
23758           IF ( IA.EQ.0 ) GOTO 660
23759           SUM  = SUM+PDF1(IA)*PDF2(IA)
23760           IF ( SUM.GE.SCHECK ) GOTO 670
23761  660      CONTINUE
23762  670    IB     = IA
23763       ELSEIF ( MSPR.EQ.8 ) THEN
23764         DO 690 IA=-NF,NF
23765           IF ( IA.EQ.0 ) GOTO 690
23766           DO 680 IB=-NF,NF
23767             IF ( ABS(IB).EQ.ABS(IA)  .OR.  IB.EQ.0 ) GOTO 680
23768             SUM = SUM+PDF1(IA)*PDF2(IB)
23769             IF ( SUM.GE.SCHECK ) GOTO 700
23770  680        CONTINUE
23771  690      CONTINUE
23772  700    CONTINUE
23773       ELSEIF ( MSPR.EQ.10 ) THEN
23774         IA     = 0
23775         DO 710 IB=-NF,NF
23776           IF ( IB.NE.0 ) THEN
23777             IF(IDPDG1.EQ.22) THEN
23778 *             IF(MOD(ABS(IB),2).EQ.0) THEN
23779 *               SUM = SUM+PDF2(IB)*4.D0/9.D0
23780 *             ELSE
23781 *               SUM = SUM+PDF2(IB)*1.D0/9.D0
23782 *             ENDIF
23783               SUM = SUM+PDF2(IB)*Q_ch2(IB)
23784             ELSE
23785               SUM = SUM+PDF2(IB)
23786             ENDIF
23787             IF ( SUM.GE.SCHECK ) GOTO 720
23788           ENDIF
23789  710    CONTINUE
23790  720    CONTINUE
23791       ELSEIF ( MSPR.EQ.12 ) THEN
23792         IB     = 0
23793         DO 810 IA=-NF,NF
23794           IF ( IA.NE.0 ) THEN
23795             IF(IDPDG2.EQ.22) THEN
23796 *             IF(MOD(ABS(IA),2).EQ.0) THEN
23797 *               SUM = SUM+PDF1(IA)*4.D0/9.D0
23798 *             ELSE
23799 *               SUM = SUM+PDF1(IA)*1.D0/9.D0
23800 *             ENDIF
23801               SUM = SUM+PDF1(IA)*Q_ch2(IA)
23802             ELSE
23803               SUM = SUM+PDF1(IA)
23804             ENDIF
23805             IF ( SUM.GE.SCHECK ) GOTO 820
23806           ENDIF
23807  810    CONTINUE
23808  820    CONTINUE
23809       ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23810         IA     = 0
23811         IB     = 0
23812       ENDIF
23813 C  final check
23814       IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
23815         print LO,'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23816         print LO,'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
23817         GOTO 111
23818       ENDIF
23819 C
23820 C  find flavour of final partons
23821 C
23822       IC = IA
23823       ID = IB
23824       IF     ( MSPR.EQ.2 ) THEN
23825         IC = 0
23826         ID = 0
23827       ELSEIF ( MSPR.EQ.4 ) THEN
23828         IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23829         IF ( IC.GT.NF ) IC = NF-IC
23830         ID =-IC
23831       ELSEIF ( MSPR.EQ.6 ) THEN
23832         IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23833         IF ( IC.GT.NF-1 ) IC = NF-1-IC
23834         IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23835         ID =-IC
23836       ELSEIF ( MSPR.EQ.11) THEN
23837         SUM = 0.D0
23838         DO 730 IC=-NF,NF
23839           IF ( IC.NE.0 ) THEN
23840             IF(IDPDG1.EQ.22) THEN
23841 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23842 *               SUM = SUM + 4.D0
23843 *             ELSE
23844 *               SUM = SUM + 1.D0
23845 *             ENDIF
23846               SUM = SUM + Q_ch2(IC)
23847             ELSE
23848               SUM = SUM + 1.D0
23849             ENDIF
23850           ENDIF
23851  730    CONTINUE
23852         SCHECK = DT_RNDM(SUM)*SUM-EPS
23853         SUM = 0.D0
23854         DO 740 IC=-NF,NF
23855           IF ( IC.NE.0 ) THEN
23856             IF(IDPDG1.EQ.22) THEN
23857 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23858 *               SUM = SUM + 4.D0
23859 *             ELSE
23860 *               SUM = SUM + 1.D0
23861 *             ENDIF
23862               SUM = SUM + Q_ch2(IC)
23863             ELSE
23864               SUM = SUM + 1.D0
23865             ENDIF
23866             IF ( SUM.GE.SCHECK ) GOTO 750
23867           ENDIF
23868  740    CONTINUE
23869  750    CONTINUE
23870         ID = -IC
23871       ELSEIF ( MSPR.EQ.12) THEN
23872         IC = 0
23873         ID = IA
23874       ELSEIF ( MSPR.EQ.13) THEN
23875         SUM = 0.D0
23876         DO 830 IC=-NF,NF
23877           IF ( IC.NE.0 ) THEN
23878             IF(IDPDG2.EQ.22) THEN
23879 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23880 *               SUM = SUM + 4.D0
23881 *             ELSE
23882 *               SUM = SUM + 1.D0
23883 *             ENDIF
23884               SUM = SUM +  Q_ch2(IC)
23885             ELSE
23886               SUM = SUM + 1.D0
23887             ENDIF
23888           ENDIF
23889  830    CONTINUE
23890         SCHECK = DT_RNDM(SUM)*SUM-EPS
23891         SUM = 0.D0
23892         DO 840 IC=-NF,NF
23893           IF ( IC.NE.0 ) THEN
23894             IF(IDPDG2.EQ.22) THEN
23895 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23896 *               SUM = SUM + 4.D0
23897 *             ELSE
23898 *               SUM = SUM + 1.D0
23899 *             ENDIF
23900               SUM = SUM +  Q_ch2(IC)
23901             ELSE
23902               SUM = SUM + 1.D0
23903             ENDIF
23904             IF ( SUM.GE.SCHECK ) GOTO 850
23905           ENDIF
23906  840    CONTINUE
23907  850    CONTINUE
23908         ID = -IC
23909       ELSEIF ( MSPR.EQ.14) THEN
23910         SUM = 0.D0
23911         DO 930 IC=1,NF
23912           FAC1 = 1.D0
23913           FAC2 = 1.D0
23914           IF(MOD(ABS(IC),2).EQ.0) THEN
23915             IF(IDPDG1.EQ.22) FAC1 = 4.D0
23916             IF(IDPDG2.EQ.22) FAC2 = 4.D0
23917           ENDIF
23918           SUM = SUM + FAC1*FAC2
23919  930    CONTINUE
23920         IF(IPAMDL(64).NE.0) THEN
23921           IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
23922         ENDIF
23923         SCHECK = DT_RNDM(SUM)*SUM-EPS
23924         SUM = 0.D0
23925         DO 940 IC=1,NF
23926           FAC1 = 1.D0
23927           FAC2 = 1.D0
23928           IF(MOD(ABS(IC),2).EQ.0) THEN
23929             IF(IDPDG1.EQ.22) FAC1 = 4.D0
23930             IF(IDPDG2.EQ.22) FAC2 = 4.D0
23931           ENDIF
23932           SUM = SUM + FAC1*FAC2
23933           IF ( SUM.GE.SCHECK ) GOTO 950
23934  940    CONTINUE
23935         IC = 15
23936  950    CONTINUE
23937         ID = -IC
23938         IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
23939       ENDIF
23940       if(IC.eq.0) then
23941         XM3 = 0.D0
23942       else
23943         XM3 = PHO_PMASS(IC,3)
23944       endif
23945       if(ID.eq.0) then
23946         XM4 = 0.D0
23947       else
23948         XM4 = PHO_PMASS(ID,3)
23949       endif
23950       IF(ABS(IC).EQ.15) GOTO 955
23951
23952 C  valence quarks involved?
23953       IV1 = 0
23954       IF(IA.NE.0) THEN
23955         IF(IDPDG1.EQ.22) THEN
23956           CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
23957           IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
23958         ELSE
23959           IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
23960         ENDIF
23961       ENDIF
23962       IV2 = 0
23963       IF(IB.NE.0) THEN
23964         IF(IDPDG2.EQ.22) THEN
23965           CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
23966           IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
23967         ELSE
23968           IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
23969         ENDIF
23970       ENDIF
23971 C
23972 C  fill event record
23973 C
23974  955  CONTINUE
23975       CALL PHO_SFECFE(SINPHI,COSPHI)
23976       ECM2 = ECMP/2.D0
23977 C  incoming partons
23978       PHI1(1) = 0.D0
23979       PHI1(2) = 0.D0
23980       PHI1(3) = ECM2*X1
23981       PHI1(4) = PHI1(3)
23982       PHI1(5) = 0.D0
23983       PHI2(1) = 0.D0
23984       PHI2(2) = 0.D0
23985       PHI2(3) = -ECM2*X2
23986       PHI2(4) = -PHI2(3)
23987       PHI2(5) = 0.D0
23988 C  outgoing partons
23989       PHO1(1) = PT*COSPHI
23990       PHO1(2) = PT*SINPHI
23991       PHO1(3) = -ECM2*(U*X1-V*X2)
23992       PHO1(4) = -ECM2*(U*X1+V*X2)
23993       PHO1(5) = XM3
23994       PHO2(1) = -PHO1(1)
23995       PHO2(2) = -PHO1(2)
23996       PHO2(3) = -ECM2*(V*X1-U*X2)
23997       PHO2(4) = -ECM2*(V*X1+U*X2)
23998       PHO2(5) = XM4
23999
24000 C  convert to mass shell
24001       CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
24002       IF(IREJ.NE.0) THEN
24003         IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
24004      &    'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
24005      &    PT,XM3,XM4
24006         GOTO 111
24007       ENDIF
24008       PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
24009
24010 C  debug output
24011       IF(IDEB(78).GE.20) THEN
24012         SHAT = X1*X2*ECMP*ECMP
24013         WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
24014      &    MSPR,IA,IB,IC,ID
24015         WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
24016         WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
24017         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
24018         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
24019         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
24020         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
24021       ENDIF
24022
24023       END
24024
24025 CDECK  ID>, PHO_HARFAC
24026       SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
24027 C*********************************************************************
24028 C
24029 C     initialization: find scaling factors and maxima of remaining
24030 C                     weights
24031 C
24032 C     input:   PTCUT  transverse momentum cutoff
24033 C              ECMI   cms energy
24034 C
24035 C     output:  Hfac(-1:Max_pro_2)  field for sampling hard processes
24036 C
24037 C*********************************************************************
24038       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24039       SAVE
24040
24041       PARAMETER ( MXABWT = 96 )
24042
24043 C  input/output channels
24044       INTEGER LI,LO
24045       COMMON /POINOU/ LI,LO
24046 C  data of c.m. system of Pomeron / Reggeon exchange
24047       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24048       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24049      &                 SIDP,CODP,SIFP,COFP
24050       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24051      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
24052      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
24053 C  some constants
24054       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24055       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24056      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24057 C  hard scattering parameters used for most recent hard interaction
24058       INTEGER NFbeta,NF
24059       DOUBLE PRECISION ALQCD2,BQCD
24060       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24061 C  integration precision for hard cross sections (obsolete)
24062       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24063       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24064 C  data on most recent hard scattering
24065       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24066       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24067      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24068      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24069       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24070      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24071      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24072      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24073      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24074 C  hard cross sections and MC selection weights
24075       INTEGER Max_pro_2
24076       PARAMETER ( Max_pro_2 = 16 )
24077       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24078      &  MH_acc_1,MH_acc_2
24079       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24080       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24081      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24082      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24083      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24084      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24085
24086       DIMENSION       ABSZ(MXABWT),WEIG(MXABWT)
24087       DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24088      &          F124(-1:Max_pro_2)
24089       DATA F124 / 1.D0,0.D0,
24090      &            4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24091      &            2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24092
24093       SS     = ECMI*ECMI
24094       AH     = (2.D0*PTCUT/ECMI)**2
24095       ALN    = LOG(AH)
24096       HLN    = LOG(0.5D0)
24097       NPOINT = NGAUIN
24098       CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24099       DO 10 M=-1,Max_pro_2
24100         S1(M) = 0.D0
24101 10    CONTINUE
24102
24103 C  resolved processes
24104       DO 80 I1=1,NPOINT
24105         Z1   = ABSZ(I1)
24106         X1   = EXP(ALN*Z1)
24107         DO 20 M=-1,9
24108           S2(M) = 0.D0
24109 20      CONTINUE
24110
24111         DO 60 I2=1,NPOINT
24112           Z2    = (1.D0-Z1)*ABSZ(I2)
24113           X2    = EXP(ALN*Z2)
24114           FAXX  = AH/(X1*X2)
24115           W     = SQRT(1.D0-FAXX)
24116           W1    = FAXX/(1.+W)
24117           WLOG  = LOG(W1)
24118           FWW   = FAXX*WLOG/W
24119           DO 30 M=-1,9
24120             S(M) = 0.D0
24121 30        CONTINUE
24122
24123           DO 40 I=1,NPOINT
24124             Z   = ABSZ(I)
24125             VA  =-0.5D0*W1/(W1+Z*W)
24126             UA  =-1.D0-VA
24127             VB  =-0.5D0*FAXX/(W1+2.D0*W*Z)
24128             UB  =-1.D0-VB
24129             VC  =-EXP(HLN+Z*WLOG)
24130             UC  =-1.D0-VC
24131             VE  =-0.5D0*(1.D0+W)+Z*W
24132             UE  =-1.D0-VE
24133             S(1)  = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24134      &           WEIG(I)
24135             S(2)  = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24136      &            WEIG(I)
24137             S(3)  = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24138             S(5)  = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24139      &            (8./27.)*UA*UA*VA)*WEIG(I)
24140             S(6)  = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24141             S(7)  = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24142      &            (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24143             S(8)  = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24144             S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
24145 40        CONTINUE
24146           S(4)    = S(2)*(9./32.)
24147           DO 50 M=-1,8
24148             S2(M) = S2(M)+S(M)*WEIG(I2)*W
24149 50        CONTINUE
24150 60      CONTINUE
24151         DO 70 M=-1,8
24152           S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
24153 70      CONTINUE
24154 80    CONTINUE
24155       S1(4) = S1(4)*NF
24156       S1(6) = S1(6)*MAX(0,NF-1)
24157 C
24158 C  direct processes
24159       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24160      &   .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24161         DO 180 I1=1,NPOINT
24162           Z2   = ABSZ(I1)
24163           X2   = EXP(ALN*Z2)
24164           FAXX  = AH/X2
24165           W     = SQRT(1.D0-FAXX)
24166           W1    = FAXX/(1.D0+W)
24167           WLOG  = LOG(W1)
24168           WL = LOG(FAXX/(1.D0+W)**2)
24169           FWW1  = FAXX*WL/ALN
24170           FWW2  = FAXX*WLOG/ALN
24171           DO 130 M=10,12
24172             S(M) = 0.D0
24173  130      CONTINUE
24174 C
24175           DO 140 I=1,NPOINT
24176             Z   = ABSZ(I)
24177             UA  =-(1.D0+W)/2.D0*EXP(Z*WL)
24178             VA  =-1.D0-UA
24179             VB  =-EXP(HLN+Z*WLOG)
24180             UB  =-1.D0-VB
24181             S(10)  = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24182             S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24183  140      CONTINUE
24184           DO 170 M=10,11
24185             S1(M) = S1(M)+S(M)*WEIG(I1)
24186  170      CONTINUE
24187  180    CONTINUE
24188         S1(12) = S1(10)
24189         S1(13) = S1(11)
24190 C  quark charges fractions
24191         IF(IDPDG1.EQ.22) THEN
24192           CHRNF = 0.D0
24193           DO 100 I=1,NF
24194             CHRNF = CHRNF + Q_ch2(I)
24195  100      CONTINUE
24196           S1(11) = S1(11)*CHRNF
24197         ELSE IF(IDPDG1.EQ.990) THEN
24198           S1(11) = S1(11)*NF
24199         ELSE
24200           S1(11) = 0.D0
24201         ENDIF
24202         IF(IDPDG2.EQ.22) THEN
24203           CHRNF = 0.D0
24204           DO 200 I=1,NF
24205             CHRNF = CHRNF + Q_ch2(I)
24206  200      CONTINUE
24207           S1(13) = S1(13)*CHRNF
24208         ELSE IF(IDPDG2.EQ.990) THEN
24209           S1(13) = S1(13)*NF
24210         ELSE
24211           S1(13) = 0.D0
24212         ENDIF
24213       ENDIF
24214 C
24215 C  global factors
24216       FFF    = PI*GEV2MB*ALN*ALN/(AH*SS)
24217       DO 90 M=-1,Max_pro_2
24218         Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
24219 90    CONTINUE
24220 C
24221 C  double direct process
24222       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24223      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24224         FAC = 0.D0
24225         DO 300 I=1,NF
24226           IF(IDPDG1.EQ.22) THEN
24227             F1 = Q_ch2(I)
24228           ELSE
24229             F1 = 1.D0
24230           ENDIF
24231           IF(IDPDG2.EQ.22) THEN
24232             F2 = Q_ch2(I)
24233           ELSE
24234             F2 = 1.D0
24235           ENDIF
24236           FAC = FAC+F1*F2*3.D0
24237  300    CONTINUE
24238         ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24239         Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24240      &               *GEV2MB*FAC
24241       ENDIF
24242       END
24243
24244 CDECK  ID>, PHO_HARWGX
24245       SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24246 C**********************************************************************
24247 C
24248 C     find maximum of remaining weight for MC sampling
24249 C
24250 C     input:   PTCUT  transverse momentum cutoff
24251 C              ECM    cms energy
24252 C
24253 C     output:  HWgx(-1:Max_pro_2)  field for sampling hard processes
24254 C
24255 C**********************************************************************
24256       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24257       SAVE
24258
24259       PARAMETER ( NKM = 10 )
24260       PARAMETER ( TINY = 1.D-20 )
24261
24262 C  input/output channels
24263       INTEGER LI,LO
24264       COMMON /POINOU/ LI,LO
24265 C  event debugging information
24266       INTEGER NMAXD
24267       PARAMETER (NMAXD=100)
24268       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24269      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24270       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24271      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24272 C  data on most recent hard scattering
24273       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24274       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24275      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24276      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24277       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24278      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24279      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24280      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24281      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24282 C  hard cross sections and MC selection weights
24283       INTEGER Max_pro_2
24284       PARAMETER ( Max_pro_2 = 16 )
24285       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24286      &  MH_acc_1,MH_acc_2
24287       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24288       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24289      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24290      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24291      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24292      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24293
24294       DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24295      &  XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24296       DIMENSION IFTAB(-1:Max_pro_2)
24297       DATA IFTAB  / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24298
24299 C  initial settings
24300       AH    = (2.D0*PTCUT/ECM)**2
24301       ALNH  = LOG(AH)
24302       FF(0) = 0.D0
24303       DO 22 I=1,NKM
24304         FF(I) = 0.D0
24305         XM1(I) = 0.D0
24306         XM2(I) = 0.D0
24307         PTM(I) = 0.D0
24308         ZMX(1,I) = 0.D0
24309         ZMX(2,I) = 0.D0
24310         ZMX(3,I) = 0.D0
24311         DMX(1,I) = 0.D0
24312         DMX(2,I) = 0.D0
24313         DMX(3,I) = 0.D0
24314         IMX(I) = 0
24315         IPO(I) = 0
24316  22   CONTINUE
24317
24318       NKML = 10
24319       DO 40 NKON=1,NKML
24320
24321         DO 50 IST=1,3
24322 C  start configuration
24323         IF(IST.EQ.1) THEN
24324           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24325           Z(2) = 0.5
24326           Z(3) = 0.1
24327           D(1) =-0.5
24328           D(2) = 0.5
24329           D(3) = 0.5
24330         ELSE IF(IST.EQ.2) THEN
24331           Z(1) = 0.999D0
24332           Z(2) = 0.5
24333           Z(3) = 0.0
24334           D(1) =-0.5
24335           D(2) = 0.5
24336           D(3) = 0.5
24337         ELSE IF(IST.EQ.3) THEN
24338           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24339           Z(2) = 0.1
24340           Z(3) = 0.1
24341           D(1) =-0.5
24342           D(2) = 0.5
24343           D(3) = 0.5
24344         ELSE IF(IST.EQ.4) THEN
24345           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24346           Z(2) = 0.9
24347           Z(3) = 0.1
24348           D(1) =-0.5
24349           D(2) = 0.5
24350           D(3) = 0.5
24351         ENDIF
24352         IT   = 0
24353         CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24354 C  process possible?
24355         IF(F2.LE.0.D0) GOTO 35
24356
24357  10     CONTINUE
24358           IT   = IT+1
24359           FOLD = F2
24360           DO 30 I=1,3
24361             D(I) = D(I)/5.D0
24362             Z(I)   = Z(I)+D(I)
24363             CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24364             IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24365             IF ( F2.GT.F3 ) D(I) =-D(I)
24366  20         CONTINUE
24367               F1   = MIN(F2,F3)
24368               F2   = MAX(F2,F3)
24369               Z(I) = Z(I)+D(I)
24370               CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24371             IF ( F3.GT.F2 ) GOTO 20
24372             ZZ     = Z(I)-D(I)
24373             Z(I)   = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24374             IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24375      &        CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24376             IF ( F1.LE.F2 ) Z(I) = ZZ
24377             F2     = MAX(F1,F2)
24378  30       CONTINUE
24379         IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24380
24381         IF(F2.GT.FF(NKON)) THEN
24382           FF(NKON)  = MAX(F2,0.D0)
24383           XM1(NKON) = X1
24384           XM2(NKON) = X2
24385           PTM(NKON) = PT
24386           ZMX(1,NKON) = Z(1)
24387           ZMX(2,NKON) = Z(2)
24388           ZMX(3,NKON) = Z(3)
24389           DMX(1,NKON) = D(1)
24390           DMX(2,NKON) = D(2)
24391           DMX(3,NKON) = D(3)
24392           IMX(NKON) = IT
24393           IPO(NKON) = IST
24394         ENDIF
24395 C
24396  50     CONTINUE
24397  35     CONTINUE
24398  40   CONTINUE
24399
24400 C  debug output
24401       IF(IDEB(38).GE.5) THEN
24402         WRITE(LO,'(/1X,A)')
24403      &    'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24404         DO 60 I=1,NKM
24405           IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24406      &      IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24407      &      DMX(2,I),DMX(3,I)
24408  60     CONTINUE
24409       ENDIF
24410
24411       DO 70 I=-1,Max_pro_2
24412         HWgx(I)  = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24413  70   CONTINUE
24414
24415 C  debug output
24416       IF(IDEB(38).GE.5) THEN
24417         WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24418         WRITE(LO,'(5X,A)') 'I    X1   X2   PT   HWgx(I)  FDIS'
24419         DO 80 I=-1,Max_pro_2
24420           IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24421             MSPR = I
24422             X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24423             X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24424             PT = PTM(IFTAB(I))
24425             CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24426             WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24427           ENDIF
24428  80     CONTINUE
24429       ENDIF
24430
24431       END
24432
24433 CDECK  ID>, PHO_HARWGI
24434       SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24435 C**********************************************************************
24436 C
24437 C     auxiliary subroutine to find maximum of remaining weight
24438 C
24439 C     input:  ECMX   current CMS energy
24440 C             PTCUT  current pt cutoff
24441 C             NKON   process label  1..5  resolved
24442 C                                   6..7  direct particle 1
24443 C                                   8..9  direct particle 2
24444 C                                   10    double direct
24445 C             Z(3)   transformed variable
24446 C
24447 C     output: remaining weight
24448 C
24449 C**********************************************************************
24450       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24451       SAVE
24452
24453       DIMENSION Z(3)
24454
24455       PARAMETER ( NKM   = 10 )
24456       PARAMETER ( TINY  = 1.D-30,
24457      &            TINY6 = 1.D-06 )
24458
24459 C  input/output channels
24460       INTEGER LI,LO
24461       COMMON /POINOU/ LI,LO
24462 C  event debugging information
24463       INTEGER NMAXD
24464       PARAMETER (NMAXD=100)
24465       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24466      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24467       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24468      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24469 C  model switches and parameters
24470       CHARACTER*8 MDLNA
24471       INTEGER ISWMDL,IPAMDL
24472       DOUBLE PRECISION PARMDL
24473       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24474 C  data of c.m. system of Pomeron / Reggeon exchange
24475       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24476       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24477      &                 SIDP,CODP,SIFP,COFP
24478       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24479      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
24480      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
24481 C  currently activated parton density parametrizations
24482       CHARACTER*8 PDFNAM
24483       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24484       DOUBLE PRECISION PDFLAM,PDFQ2M
24485       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24486      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24487 C  hard scattering parameters used for most recent hard interaction
24488       INTEGER NFbeta,NF
24489       DOUBLE PRECISION ALQCD2,BQCD
24490       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24491 C  some hadron information, will be deleted in future versions
24492       INTEGER NFS
24493       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24494       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24495 C  scale parameters for parton model calculations
24496       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24497       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24498       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24499      &                NQQAL,NQQALI,NQQALF,NQQPD
24500 C  data on most recent hard scattering
24501       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24502       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24503      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24504      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24505       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24506      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24507      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24508      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24509      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24510
24511       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24512       DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24513
24514       FDIS = 0.D0
24515
24516       IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24517      &  'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24518 C  check input values
24519       IF ( Z(1).LT.0.D0  .OR.  Z(1).GT.1.D0 ) RETURN
24520       IF ( Z(2).LT.0.D0  .OR.  Z(2).GT.1.D0 ) RETURN
24521       IF ( Z(3).LT.0.D0  .OR.  Z(3).GT.1.D0 ) RETURN
24522 C  transformations
24523       Y1    = EXP(ALNH*Z(1))
24524       IF(NKON.LE.5) THEN
24525 C  resolved kinematic
24526         Y2  =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24527         X1  = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24528         X2  = X1-Y2
24529         X1 = MIN(X1,0.999999999999D0)
24530         X2 = MIN(X2,0.999999999999D0)
24531       ELSE IF(NKON.LE.7) THEN
24532 C  direct kinematic 1
24533         X1 = 1.D0
24534         X2 = MIN(Y1,0.999999999999D0)
24535       ELSE IF(NKON.LE.9) THEN
24536 C  direct kinematic 2
24537         X1 = MIN(Y1,0.999999999999D0)
24538         X2 = 1.D0
24539       ELSE
24540 C  double direct kinematic
24541         X1 = 1.D0
24542         X2 = 1.D0
24543       ENDIF
24544       W   = SQRT(MAX(TINY,1.D0-AH/Y1))
24545       V   =-0.5D0+W*(Z(3)-0.5D0)
24546       U   =-(1.D0+V)
24547       PT  = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24548
24549 C  set hard scale  QQ  for alpha and partondistr.
24550       IF     ( NQQAL.EQ.1 ) THEN
24551         QQAL = AQQAL*PT*PT
24552       ELSEIF ( NQQAL.EQ.2 ) THEN
24553         QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24554       ELSEIF ( NQQAL.EQ.3 ) THEN
24555         QQAL = AQQAL*Y1*ECMX*ECMX
24556       ELSEIF ( NQQAL.EQ.4 ) THEN
24557         QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24558       ENDIF
24559       IF     ( NQQPD.EQ.1 ) THEN
24560         QQPD = AQQPD*PT*PT
24561       ELSEIF ( NQQPD.EQ.2 ) THEN
24562         QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24563       ELSEIF ( NQQPD.EQ.3 ) THEN
24564         QQPD = AQQPD*Y1*ECMX*ECMX
24565       ELSEIF ( NQQPD.EQ.4 ) THEN
24566         QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24567       ENDIF
24568 C
24569       IF(NKON.LE.5) THEN
24570         DO 10 N=1,5
24571           F(N) = 0.D0
24572  10     CONTINUE
24573 C  resolved processes
24574         ALPHA1 = PHO_ALPHAS(QQAL,3)
24575         ALPHA2 = ALPHA1
24576         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24577         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24578 C  calculate full distribution FDIS
24579         DO 20 I=1,NF
24580           F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24581           F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24582           F(4) = F(4)+PDA(I)+PDA(-I)
24583           F(5) = F(5)+PDB(I)+PDB(-I)
24584 20      CONTINUE
24585         F(1)   = PDA(0)*PDB(0)
24586         T      = PDA(0)*F(5)+PDB(0)*F(4)
24587         F(5)   = F(4)*F(5)-(F(2)+F(3))
24588         F(4)   = T
24589       ELSE IF(NKON.LE.7) THEN
24590 C  direct processes particle 1
24591         IF(IDPDG1.EQ.22) THEN
24592           ALPHA1 = pho_alphae(QQAL)
24593           CH1 = 4.D0/9.D0
24594           CH2 = 3.D0/9.D0
24595         ELSE IF(IDPDG1.EQ.990) THEN
24596           ALPHA1 = PARMDL(74)
24597           CH1 = 1.D0
24598           CH2 = 0.D0
24599         ELSE
24600           FDIS = -1.D0
24601           RETURN
24602         ENDIF
24603         ALPHA2 = PHO_ALPHAS(QQAL,2)
24604         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24605         F(6) = 0.D0
24606         DO 30 I=1,NF
24607           F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24608  30     CONTINUE
24609         F(7)   = PDB(0)
24610       ELSE IF(NKON.LE.9) THEN
24611 C  direct processes particle 2
24612         ALPHA1 = PHO_ALPHAS(QQAL,1)
24613         IF(IDPDG2.EQ.22) THEN
24614           ALPHA2 = pho_alphae(QQAL)
24615           CH1 = 4.D0/9.D0
24616           CH2 = 3.D0/9.D0
24617         ELSE IF(IDPDG2.EQ.990) THEN
24618           ALPHA2 = PARMDL(74)
24619           CH1 = 1.D0
24620           CH2 = 0.D0
24621         ELSE
24622           FDIS = -1.D0
24623           RETURN
24624         ENDIF
24625         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24626         F(8) = 0.D0
24627         DO 40 I=1,NF
24628           F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24629  40     CONTINUE
24630         F(9)   = PDA(0)
24631       ELSE
24632 C  double direct process
24633         SSR = ECMX*ECMX
24634         IF(IDPDG1.EQ.22) THEN
24635           ALPHA1 = pho_alphae(SSR)
24636         ELSE IF(IDPDG1.EQ.990) THEN
24637           ALPHA1 = PARMDL(74)
24638         ELSE
24639           FDIS = -1.D0
24640           RETURN
24641         ENDIF
24642         IF(IDPDG2.EQ.22) THEN
24643           ALPHA2 = pho_alphae(SSR)
24644         ELSE IF(IDPDG2.EQ.990) THEN
24645           ALPHA2 = PARMDL(74)
24646         ELSE
24647           FDIS = -1.D0
24648           RETURN
24649         ENDIF
24650         F(10) = 1.D0
24651       ENDIF
24652
24653       FDIS   = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24654
24655 C  debug output
24656       IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24657      &  'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24658      &  NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24659
24660       END
24661
24662 CDECK  ID>, PHO_HARINI
24663       SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24664 C**********************************************************************
24665 C
24666 C     initialize calculation of hard cross section
24667 C
24668 C     must not be called during MC generation
24669 C
24670 C***********************************************************************
24671       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24672       SAVE
24673
24674       PARAMETER ( DEPS   = 1.D-10 )
24675
24676 C  input/output channels
24677       INTEGER LI,LO
24678       COMMON /POINOU/ LI,LO
24679 C  event debugging information
24680       INTEGER NMAXD
24681       PARAMETER (NMAXD=100)
24682       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24683      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24684       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24685      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24686 C  model switches and parameters
24687       CHARACTER*8 MDLNA
24688       INTEGER ISWMDL,IPAMDL
24689       DOUBLE PRECISION PARMDL
24690       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24691 C  currently activated parton density parametrizations
24692       CHARACTER*8 PDFNAM
24693       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24694       DOUBLE PRECISION PDFLAM,PDFQ2M
24695       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24696      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24697 C  some constants
24698       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24699       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24700      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24701 C  scale parameters for parton model calculations
24702       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24703       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24704       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24705      &                NQQAL,NQQALI,NQQALF,NQQPD
24706 C  data of c.m. system of Pomeron / Reggeon exchange
24707       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24708       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24709      &                 SIDP,CODP,SIFP,COFP
24710       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24711      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
24712      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
24713 C  obsolete cut-off information
24714       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24715       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24716 C  hard scattering parameters used for most recent hard interaction
24717       INTEGER NFbeta,NF
24718       DOUBLE PRECISION ALQCD2,BQCD
24719       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24720
24721       double precision pho_alphas
24722
24723       CHARACTER*20 RFLAG
24724
24725 C  set local Pomeron c.m. system data
24726       IDPDG1    = IDP1
24727       IDPDG2    = IDP2
24728       PVIRTP(1) = PV1
24729       PVIRTP(2) = PV2
24730 C  initialize PDFs
24731       CALL PHO_ACTPDF(IDPDG1,1)
24732       CALL PHO_ACTPDF(IDPDG2,2)
24733 C  initialize alpha_s calculation
24734       DUMMY = PHO_ALPHAS(0.D0,-4)
24735 C  initialize scales with defaults
24736       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24737         IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24738           AQQAL  = PARMDL(83)
24739           AQQALI = PARMDL(86)
24740           AQQALF = PARMDL(89)
24741           AQQPD  = PARMDL(92)
24742           NQQAL  = IPAMDL(83)
24743           NQQALI = IPAMDL(86)
24744           NQQALF = IPAMDL(89)
24745           NQQPD  = IPAMDL(92)
24746         ELSE
24747           AQQAL  = PARMDL(82)
24748           AQQALI = PARMDL(85)
24749           AQQALF = PARMDL(88)
24750           AQQPD  = PARMDL(91)
24751           NQQAL  = IPAMDL(82)
24752           NQQALI = IPAMDL(85)
24753           NQQALF = IPAMDL(88)
24754           NQQPD  = IPAMDL(91)
24755         ENDIF
24756       ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24757         AQQAL  = PARMDL(82)
24758         AQQALI = PARMDL(85)
24759         AQQALF = PARMDL(88)
24760         AQQPD  = PARMDL(91)
24761         NQQAL  = IPAMDL(82)
24762         NQQALI = IPAMDL(85)
24763         NQQALF = IPAMDL(88)
24764         NQQPD  = IPAMDL(91)
24765       ELSE
24766         AQQAL  = PARMDL(81)
24767         AQQALI = PARMDL(84)
24768         AQQALF = PARMDL(87)
24769         AQQPD  = PARMDL(90)
24770         NQQAL  = IPAMDL(81)
24771         NQQALI = IPAMDL(84)
24772         NQQALF = IPAMDL(87)
24773         NQQPD  = IPAMDL(90)
24774       ENDIF
24775       IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24776       IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24777       IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24778       IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24779       IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24780       IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24781       IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24782       IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24783       AQQAL  = PARMDL(109+IP)
24784       AQQALI = PARMDL(113+IP)
24785       AQQALF = PARMDL(117+IP)
24786       AQQPD  = PARMDL(121+IP)
24787       NQQAL  = IPAMDL(64+IP)
24788       NQQALI = IPAMDL(68+IP)
24789       NQQALF = IPAMDL(72+IP)
24790       NQQPD  = IPAMDL(76+IP)
24791       PTCUT(1) = PARMDL(36)
24792       PTCUT(2) = PARMDL(37)
24793       PTCUT(3) = PARMDL(38)
24794       PTCUT(4) = PARMDL(39)
24795       PTANO(1) = PARMDL(130)
24796       PTANO(2) = PARMDL(131)
24797       PTANO(3) = PARMDL(132)
24798       PTANO(4) = PARMDL(133)
24799       RFLAG = '(energy-independent)'
24800       IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24801
24802 C  write out all settings
24803 C *** Commented by Chiara
24804 C      IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24805 C        WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24806 C     &    PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24807 C     &    PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24808 C     &    PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
24809 C1050    FORMAT(/,
24810 C     &    ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24811 C     &    5X,'particle 1 / particle 2:',2I8,/,
24812 C     &    5X,'min. PT   :',F7.1,2X,A,/,
24813 C     &    5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24814 C     &    5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24815 C     &    5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24816 C     &    5X,'max. number of active flavours NF  :',I3,/,
24817 C     &    5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24818 C      ENDIF
24819
24820       END
24821
24822 CDECK  ID>, PHO_HARINT
24823       SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24824 C**********************************************************************
24825 C
24826 C     interpolate cross sections and weights for hard scattering
24827 C
24828 C     input:  IPP    particle combination (neg. for add. user cuts)
24829 C             ECM    CMS energy (GeV)
24830 C             P2V1/2 particle virtualities (pos., GeV**2)
24831 C             I1     first subprocess to calculate
24832 C             I2     last subprocess to calculate
24833 C                    <-1  only scales and cutoffs calculated
24834 C             K1     first variable to calculate
24835 C             K2     last variable to calculate
24836 C             MSPOM  cross sections to use for pt distribution
24837 C                    0  reggeon
24838 C                    >0 pomeron
24839 C
24840 C             for K1 < 3 the soft pt distribution is also calculated
24841 C
24842 C     output: interpolated values in HWgx, HSig, Hdpt
24843 C
24844 C***********************************************************************
24845       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24846       SAVE
24847
24848       PARAMETER ( DEPS   = 1.D-15,
24849      &            DEPS2  = 2.D-15 )
24850
24851 C  input/output channels
24852       INTEGER LI,LO
24853       COMMON /POINOU/ LI,LO
24854 C  event debugging information
24855       INTEGER NMAXD
24856       PARAMETER (NMAXD=100)
24857       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24858      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24859       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24860      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24861 C  model switches and parameters
24862       CHARACTER*8 MDLNA
24863       INTEGER ISWMDL,IPAMDL
24864       DOUBLE PRECISION PARMDL
24865       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24866 C  Reggeon phenomenology parameters
24867       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
24868      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
24869       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
24870      &                ALREG,ALREGP,GR(2),B0REG(2),
24871      &                GPPP,GPPR,B0PPP,B0PPR,
24872      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
24873 C  parameters of 2x2 channel model
24874       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
24875       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
24876 C  data needed for soft-pt calculation
24877       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
24878       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
24879 C  scale parameters for parton model calculations
24880       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24881       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24882       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24883      &                NQQAL,NQQALI,NQQALF,NQQPD
24884 C  obsolete cut-off information
24885       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24886       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24887 C  event weights and generated cross section
24888       INTEGER IPOWGC,ISWCUT,IVWGHT
24889       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
24890       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
24891      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
24892 C  parameters for DGLAP backward evolution in ISR
24893       INTEGER NFSISR
24894       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
24895       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
24896 C  hard cross sections and MC selection weights
24897       INTEGER Max_pro_2
24898       PARAMETER ( Max_pro_2 = 16 )
24899       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24900      &  MH_acc_1,MH_acc_2
24901       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24902       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24903      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24904      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24905      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24906      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24907 C  interpolation tables for hard cross section and MC selection weights
24908       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
24909       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
24910       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
24911       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
24912      &  HQ2a_tab,HQ2b_tab,HEcm_tab
24913       COMMON /POHTAB/
24914      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24915      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24916      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24917      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24918      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
24919      &  HEcm_tab(1:Max_tab_E,0:4),
24920      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
24921 C  data on most recent hard scattering
24922       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24923       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24924      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24925      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24926       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24927      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24928      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24929      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24930      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24931 C  energy-interpolation table
24932       INTEGER IEETA2
24933       PARAMETER ( IEETA2 = 20 )
24934       INTEGER ISIMAX
24935       DOUBLE PRECISION SIGTAB,SIGECM
24936       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
24937
24938       DOUBLE PRECISION XP,PTS
24939       DIMENSION XP(2),PTS(0:2,2)
24940
24941       INTEGER IV
24942       DIMENSION IV(2)
24943
24944       IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
24945      &    'PHO_HARINT: called with ',
24946      &    'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
24947      &    IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
24948
24949       IP = ABS(IPP)
24950       IF(IPP.GT.0) THEN
24951 C  default minimum bias cutoff
24952         PTCUT(IP) = pho_ptcut(ECM,IP)
24953       ELSE
24954 C  user defined additional cutoff
24955         PTCUT(IP) = HSWCUT(4+IP)
24956       ENDIF
24957       PTWANT = PTCUT(IP)
24958
24959 C  ISR cutoffs
24960       Q2CUT     = MIN(PTWANT**2,PARMDL(125+IP))
24961       Q2MISR(1) = MAX(P2V1,Q2CUT)
24962       Q2MISR(2) = MAX(P2V2,Q2CUT)
24963 C  cutoff for direct photon contribution to photon PDF
24964       PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
24965       PTA1      = PTANO(IP)
24966 C  scales for hard scattering
24967       AQQAL  = PARMDL(109+IP)
24968       AQQALI = PARMDL(113+IP)
24969       AQQALF = PARMDL(117+IP)
24970       AQQPD  = PARMDL(121+IP)
24971       NQQAL  = IPAMDL(64+IP)
24972       NQQALI = IPAMDL(68+IP)
24973       NQQALF = IPAMDL(72+IP)
24974       NQQPD  = IPAMDL(76+IP)
24975       IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
24976      &  'PHO_HARINT: scales:',
24977      &  NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
24978
24979       IF(I2.LT.-1) RETURN
24980
24981       IL = IP
24982       IF(IPP.LT.0) IL = 0
24983
24984 C  double-log interpolation
24985       IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
24986         DO 50 M=I1,I2
24987           Hfac(M) = 0.D0
24988           HWgx(M) = 0.D0
24989           HSig(M) = 0.D0
24990           Hdpt(M) = 0.D0
24991  50     CONTINUE
24992       ELSE
24993         I=1
24994  310    CONTINUE
24995           I = I+1
24996         IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
24997
24998         Ia = 1
24999         Ib = 1
25000         fac = LOG(ECM/HEcm_tab(I-1,IL))
25001      &       /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
25002         do M=I1,I2
25003 C  factor due to phase space integration
25004           XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25005      &      *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
25006      &           /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
25007           XX = EXP(XX)
25008           IF(XX.LT.DEPS2) XX = 0.D0
25009           Hfac(M) = XX
25010 C  max. weight
25011           XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25012      &      *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
25013      &           /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
25014           XX = EXP(XX)
25015           IF(XX.LT.DEPS2) XX = 0.D0
25016           HWgx(M) = XX*1.2D0
25017 C  hard cross section
25018           XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25019      &      *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
25020      &           /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
25021           XX = EXP(XX)
25022           IF(XX.LT.DEPS2) XX = 0.D0
25023           HSig(M) = XX
25024 C  differential hard cross section
25025           XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25026      &      *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
25027      &           /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
25028           XX = EXP(XX)
25029           IF(XX.LT.DEPS2) XX = 0.D0
25030           Hdpt(M) = XX
25031         enddo
25032       ENDIF
25033
25034       IF((K1.LT.3).AND.(K2.GE.3)) THEN
25035 C  cross check
25036         IF((I1.GT.9).OR.(I2.LT.9)) THEN
25037           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
25038      &      'hard cross section not calculated ',I1,I2
25039         ENDIF
25040         SIGH   = HSig(9)
25041         DSIGHP = Hdpt(9)
25042 C  load soft cross sections from interpolation table
25043         IF(ECM.LE.SIGECM(IP,1)) THEN
25044           L1 = 1
25045           L2 = 1
25046         ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
25047           DO 55 I=2,ISIMAX
25048             IF(ECM.LE.SIGECM(IP,I)) GOTO 205
25049  55       CONTINUE
25050  205      CONTINUE
25051           L1 = I-1
25052           L2 = I
25053         ELSE
25054           WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
25055      &      'PHO_HARINT: energy too high (IP,Ecm,Emax)',
25056      &      IP,ECM,SIGECM(IP,ISIMAX)
25057           CALL PHO_PREVNT(-1)
25058           L1 = ISIMAX-1
25059           L2 = ISIMAX
25060         ENDIF
25061         FAC2=0.D0
25062         IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
25063      &                    /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
25064         FAC1=1.D0-FAC2
25065         SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
25066      &         FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
25067
25068         FS = FPS(IP)
25069         FH = FPH(IP)
25070         CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
25071       ENDIF
25072
25073  300  CONTINUE
25074
25075 C  debug output
25076       IF(IDEB(58).GE.15) THEN
25077         WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25078      &    'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25079      &    KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25080         DO 162 M=I1,I2
25081           WRITE(LO,'(5X,2I3,1p,4E12.3)')
25082      &      M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25083  162    CONTINUE
25084       ENDIF
25085
25086       END
25087
25088       DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25089 C***********************************************************************
25090 C
25091 C     calculate energy-dependent transverse momentum cutoff
25092 C
25093 C***********************************************************************
25094
25095       IMPLICIT NONE
25096
25097       SAVE
25098
25099       double precision ECM
25100       integer IP
25101
25102 C  input/output channels
25103       INTEGER LI,LO
25104       COMMON /POINOU/ LI,LO
25105 C  event debugging information
25106       INTEGER NMAXD
25107       PARAMETER (NMAXD=100)
25108       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25109      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25110       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25111      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25112 C  model switches and parameters
25113       CHARACTER*8 MDLNA
25114       INTEGER ISWMDL,IPAMDL
25115       DOUBLE PRECISION PARMDL
25116       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25117
25118       pho_ptcut = PARMDL(35+IP)
25119
25120       IF(IPAMDL(7).EQ.1) THEN
25121 C  Bopp et al. type (DPMJET)
25122         pho_ptcut = PARMDL(35+IP)
25123      &             + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25124       ELSE IF(IPAMDL(7).EQ.2) THEN
25125 C  Gribov-Levin-Ryskin type
25126         pho_ptcut = PARMDL(35+IP)
25127      &             + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25128       ENDIF
25129
25130       END
25131
25132 CDECK  ID>, PHO_HARMCI
25133       SUBROUTINE PHO_HARMCI(IP,EMAXF)
25134 C**********************************************************************
25135 C
25136 C     initialize MC sampling and calculate hard cross section
25137 C
25138 C     input:  IP       particle combination (neg. number for user cut)
25139 C             EMAXF    maximum CMS energy for
25140 C                      interpolation table in reference to PTCUT(1..4)
25141 C
25142 C***********************************************************************
25143       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25144       SAVE
25145
25146       PARAMETER (DEPS   = 1.D-10,
25147      &           PLARGE = 1.D20 )
25148
25149 C  input/output channels
25150       INTEGER LI,LO
25151       COMMON /POINOU/ LI,LO
25152 C  event debugging information
25153       INTEGER NMAXD
25154       PARAMETER (NMAXD=100)
25155       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25156      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25157       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25158      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25159 C  some constants
25160       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25161       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25162      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25163 C  global event kinematics and particle IDs
25164       INTEGER IFPAP,IFPAB
25165       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25166       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25167 C  data of c.m. system of Pomeron / Reggeon exchange
25168       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25169       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25170      &                 SIDP,CODP,SIFP,COFP
25171       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25172      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25173      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25174 C  model switches and parameters
25175       CHARACTER*8 MDLNA
25176       INTEGER ISWMDL,IPAMDL
25177       DOUBLE PRECISION PARMDL
25178       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25179 C  obsolete cut-off information
25180       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25181       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25182 C  scale parameters for parton model calculations
25183       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25184       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25185       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25186      &                NQQAL,NQQALI,NQQALF,NQQPD
25187 C  names of hard scattering processes
25188       INTEGER Max_pro_1
25189       PARAMETER ( Max_pro_1 = 16 )
25190       CHARACTER*18 PROC
25191       COMMON /POHPRO/ PROC(0:Max_pro_1)
25192 C  hard cross sections and MC selection weights
25193       INTEGER Max_pro_2
25194       PARAMETER ( Max_pro_2 = 16 )
25195       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25196      &  MH_acc_1,MH_acc_2
25197       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25198       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25199      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25200      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25201      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25202      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25203 C  interpolation tables for hard cross section and MC selection weights
25204       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25205       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25206       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25207       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25208      &  HQ2a_tab,HQ2b_tab,HEcm_tab
25209       COMMON /POHTAB/
25210      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25211      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25212      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25213      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25214      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25215      &  HEcm_tab(1:Max_tab_E,0:4),
25216      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25217 C  event weights and generated cross section
25218       INTEGER IPOWGC,ISWCUT,IVWGHT
25219       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25220       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25221      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25222
25223       COMPLEX*16 DSIG
25224       DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25225
25226 C  initialization for all pt cutoffs
25227       I = ABS(IP)
25228       IL = I
25229       IF(IP.LT.0) THEN
25230         IL = 0
25231         PTC = HSWCUT(4+I)
25232       else
25233         PTC = pho_ptcut(parmdl(19),I)
25234       ENDIF
25235
25236 C  skip unassigned PTCUT
25237       IF(PTC.LT.0.5D0) GOTO 1000
25238
25239       IH_Q2a_up(I) = 1
25240       IH_Q2b_up(I) = 1
25241       do ib=1,Max_tab_Q2
25242         do ia=1,Max_tab_Q2
25243           do ie=1,Max_tab_E
25244             do m=-1,Max_pro_2
25245               Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25246               HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25247               HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25248               Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25249             enddo
25250           enddo
25251         enddo
25252       enddo
25253
25254       ELLOW = LOG(2.05*PTC)
25255       DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25256 C  energy too low
25257       IF(DELTA.LE.0.D0) GOTO 1000
25258
25259 C  switch between external particles and Pomeron
25260       IF(I.EQ.4) THEN
25261         IDP1 = 990
25262         PV1  = 0.D0
25263         IDP2 = 990
25264         PV2  = 0.D0
25265       ELSE IF(I.EQ.3) THEN
25266         IDP1 = IFPAP(2)
25267         PV1  = PVIRT(2)
25268         IDP2 = 990
25269         PV2  = 0.D0
25270       ELSE IF(I.EQ.2) THEN
25271         IDP1 = IFPAP(1)
25272         PV1  = PVIRT(1)
25273         IDP2 = 990
25274         PV2  = 0.D0
25275       ELSE
25276         IDP1 = IFPAP(1)
25277         PV1  = PVIRT(1)
25278         IDP2 = IFPAP(2)
25279         PV2  = PVIRT(2)
25280       ENDIF
25281
25282 C  initialize PT scales
25283       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25284         IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25285           FPS(I) = PARMDL(105)
25286           FPH(I) = PARMDL(106)
25287         ELSE
25288           FPS(I) = PARMDL(103)
25289           FPH(I) = PARMDL(104)
25290         ENDIF
25291       ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25292         FPS(I) = PARMDL(103)
25293         FPH(I) = PARMDL(104)
25294       ELSE
25295         FPS(I) = PARMDL(101)
25296         FPH(I) = PARMDL(102)
25297       ENDIF
25298
25299 C  initialize hard scattering
25300       IF(IP.GT.0) THEN
25301         CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25302       ELSE
25303         CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25304       ENDIF
25305
25306 C  energy/virtuality grid
25307       do Ie=1,IH_Ecm_up(IL)
25308         HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25309       enddo
25310       do Ia=1,IH_Q2a_up(IL)
25311         HQ2a_tab(Ia,IL) = 0.D0
25312       enddo
25313       do Ib=1,IH_Q2b_up(IL)
25314         HQ2b_tab(Ib,IL) = 0.D0
25315       enddo
25316
25317 C  initialization for several energies and particle virtualities
25318       do Ie=1,IH_Ecm_up(IL)
25319         do Ia=1,IH_Q2a_up(IL)
25320           do Ib=1,IH_Q2b_up(IL)
25321
25322             EE = HEcm_tab(IE,IL)
25323             Q2a = HQ2a_tab(Ia,IL)
25324             Q2b = HQ2b_tab(Ib,IL)
25325             CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25326             IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25327      &        'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25328      &        PTCUT(I),EE,IDPDG1,IDPDG2
25329             Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25330             CALL PHO_HARFAC(PTCUT(I),EE)
25331             CALL PHO_HARWGX(PTCUT(I),EE)
25332             CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25333             IF(IDEB(8).GE.10) THEN
25334               WRITE(LO,'(1X,A,/,1X,A)')
25335      &          'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25336      &          '------------------------------------------------'
25337               DO M=0,Max_pro_2
25338                 WRITE(LO,'(10X,A,1P2E14.4)')
25339      &            PROC(M),DREAL(DSIG(M)),DSPT(M)
25340               ENDDO
25341             ENDIF
25342
25343 C  store in interpolation tables
25344             Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25345             HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25346             do M=0,Max_pro_2
25347               Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25348               HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25349               HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25350               Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25351             enddo
25352
25353 C  summed quantities
25354             HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25355             Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25356             do M=1,8
25357               IF(MH_pro_on(M,I).GT.0) THEN
25358                 HSig_tab(9,IE,Ia,Ib,IL) =
25359      &            HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25360                 Hdpt_tab(9,IE,Ia,Ib,IL) =
25361      &            Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25362               ENDIF
25363             enddo
25364             HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25365             Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25366             do M=10,14
25367               IF(MH_pro_on(M,I).GT.0) THEN
25368                 HSig_tab(15,IE,Ia,Ib,IL) =
25369      &            HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25370                 Hdpt_tab(15,IE,Ia,Ib,IL) =
25371      &            Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25372               ENDIF
25373             enddo
25374             HSig_tab(0,IE,Ia,Ib,IL) =
25375      &        HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25376             Hdpt_tab(0,IE,Ia,Ib,IL) =
25377      &        Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25378
25379           enddo
25380         enddo
25381       enddo
25382
25383 C  debug output of weights
25384  1000 CONTINUE
25385       IF(IDEB(8).GE.5) THEN
25386         WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25387      &    'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25388      &    IDPDG1,IDPDG2,IP,PTCUT(I),
25389      &    '------------------------------------------'
25390         DO M=-1,Max_pro_2
25391           IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25392           WRITE(LO,'(2X,A,I3,2I7)')
25393      &      'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25394      &      M,IDPDG1,IDPDG2
25395           do k=1,IH_Ecm_up(IL)
25396             do ia=1,IH_Q2a_up(IL)
25397               do ib=1,IH_Q2b_up(IL)
25398                 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25399      &            HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25400      &            Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25401      &            HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25402               enddo
25403             enddo
25404           enddo
25405  512      CONTINUE
25406         ENDDO
25407       ENDIF
25408
25409       END
25410
25411 CDECK  ID>, PHO_HARXR3
25412       SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25413 C**********************************************************************
25414 C
25415 C     differential cross section DSIG/(DETAC*DETAD*DPT)
25416 C
25417 C     input:  ECMH     CMS energy
25418 C             PT       parton PT
25419 C             ETAC     pseudorapidity of parton C
25420 C             ETAD     pseudorapidity of parton D
25421 C
25422 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25423 C
25424 C**********************************************************************
25425       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25426       SAVE
25427
25428       PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25429
25430       PARAMETER ( Max_pro_2 = 16 )
25431       COMPLEX*16 DSIGMC
25432       DIMENSION DSIGMC(0:Max_pro_2)
25433       DIMENSION DSIGM(0:Max_pro_2)
25434
25435 C  input/output channels
25436       INTEGER LI,LO
25437       COMMON /POINOU/ LI,LO
25438 C  some constants
25439       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25440       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25441      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25442 C  Reggeon phenomenology parameters
25443       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25444      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25445       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25446      &                ALREG,ALREGP,GR(2),B0REG(2),
25447      &                GPPP,GPPR,B0PPP,B0PPR,
25448      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25449 C  currently activated parton density parametrizations
25450       CHARACTER*8 PDFNAM
25451       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25452       DOUBLE PRECISION PDFLAM,PDFQ2M
25453       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25454      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25455 C  hard scattering parameters used for most recent hard interaction
25456       INTEGER NFbeta,NF
25457       DOUBLE PRECISION ALQCD2,BQCD
25458       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25459 C  scale parameters for parton model calculations
25460       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25461       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25462       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25463      &                NQQAL,NQQALI,NQQALF,NQQPD
25464
25465       DOUBLE PRECISION PHO_ALPHAS
25466       DIMENSION PDA(-6:6),PDB(-6:6)
25467
25468       DO 10 I=1,9
25469         DSIGMC(I) = CMPLX(0.D0,0.D0)
25470         DSIGM(I)  = 0.D0
25471 10    CONTINUE
25472
25473       EC     = EXP(ETAC)
25474       ED     = EXP(ETAD)
25475 C  kinematic conversions
25476       XA     = PT*(EC+ED)/ECMH
25477       XB     = XA/(EC*ED)
25478       IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25479         WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25480         RETURN
25481       ENDIF
25482       SP     = XA*XB*ECMH*ECMH
25483       UP     =-ECMH*PT*EC*XB
25484       UP     = UP/SP
25485       TP     =-(1.D0+UP)
25486       UU     = UP*UP
25487       TT     = TP*TP
25488 C  set hard scale  QQ  for alpha and partondistr.
25489       IF     ( NQQAL.EQ.1 ) THEN
25490         QQAL = AQQAL*PT*PT
25491       ELSEIF ( NQQAL.EQ.2 ) THEN
25492         QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25493       ELSEIF ( NQQAL.EQ.3 ) THEN
25494         QQAL = AQQAL*SP
25495       ELSEIF ( NQQAL.EQ.4 ) THEN
25496         QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25497       ENDIF
25498       IF     ( NQQPD.EQ.1 ) THEN
25499         QQPD = AQQPD*PT*PT
25500       ELSEIF ( NQQPD.EQ.2 ) THEN
25501         QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25502       ELSEIF ( NQQPD.EQ.3 ) THEN
25503         QQPD = AQQPD*SP
25504       ELSEIF ( NQQPD.EQ.4 ) THEN
25505         QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25506       ENDIF
25507
25508       ALPHA  = PHO_ALPHAS(QQAL,3)
25509       FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25510 C  parton distributions (times x)
25511       CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25512       CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25513       S1    = PDA(0)*PDB(0)
25514       S2    = 0.D0
25515       S3    = 0.D0
25516       S4    = 0.D0
25517       S5    = 0.D0
25518       DO 20 I=1,NF
25519         S2  = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25520         S3  = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25521         S4  = S4+PDA(I)+PDA(-I)
25522         S5  = S5+PDB(I)+PDB(-I)
25523 20    CONTINUE
25524 C  partial cross sections (including color and symmetry factors)
25525 C  resolved photon matrix elements (light quarks)
25526       DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25527       DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25528       DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25529       DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25530       DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25531       DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25532       DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25533       DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25534      &           (8.D0/27.D0)/(UP*TP))
25535 C
25536       DSIGM(1) = FACTOR*DSIGM(1)*S1
25537       DSIGM(2) = FACTOR*DSIGM(2)*S2
25538       DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25539       DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25540       DSIGM(5) = FACTOR*DSIGM(5)*S2
25541       DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25542       DSIGM(7) = FACTOR*DSIGM(7)*S3
25543       DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25544 C  complex part
25545       X=ABS(TP-UP)
25546       FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25547 C
25548       DO 50 I=1,8
25549         IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25550         DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25551         DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25552  50   CONTINUE
25553       END
25554
25555 CDECK  ID>, PHO_HARXR2
25556       SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25557 C**********************************************************************
25558 C
25559 C     differential cross section DSIG/(DETAC*DPT)
25560 C
25561 C     input:  ECMH     CMS energy
25562 C             PT       parton PT
25563 C             ETAC     pseudorapidity of parton C
25564 C
25565 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25566 C
25567 C**********************************************************************
25568       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25569       SAVE
25570
25571       PARAMETER ( TINY= 1.D-20 )
25572
25573       PARAMETER ( Max_pro_2 = 16 )
25574       COMPLEX*16 DSIGMC
25575       DIMENSION DSIGMC(0:Max_pro_2)
25576
25577 C  input/output channels
25578       INTEGER LI,LO
25579       COMMON /POINOU/ LI,LO
25580 C  integration precision for hard cross sections (obsolete)
25581       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25582       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25583
25584       COMPLEX*16 DSIG1
25585       DIMENSION DSIG1(0:Max_pro_2)
25586       DIMENSION ABSZ(32),WEIG(32)
25587
25588       DO 10 M=1,9
25589         DSIGMC(M) = CMPLX(0.D0,0.D0)
25590         DSIG1(M)  = 0.D0
25591 10    CONTINUE
25592 C
25593       EC  = EXP(ETAC)
25594       ARG = ECMH/PT
25595       IF  ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25596       EDU = LOG(ARG-EC)
25597       EDL =-LOG(ARG-1.D0/EC)
25598       NPOINT = NGAUET
25599       CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25600       DO 30 I=1,NPOINT
25601         CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25602         DO 20 M=1,9
25603           PCTRL= DREAL(DSIG1(M))/TINY
25604           IF( PCTRL.GE.1.D0 ) THEN
25605             DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25606           ENDIF
25607 20      CONTINUE
25608 30    CONTINUE
25609       END
25610
25611 CDECK  ID>, PHO_HARXD2
25612       SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25613 C**********************************************************************
25614 C
25615 C     differential cross section DSIG/(DETAC*DPT) for direct processes
25616 C
25617 C     input:  ECMH     CMS energy of scattering system
25618 C             PT       parton PT
25619 C             ETAC     pseudorapidity of parton C
25620 C
25621 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25622 C
25623 C**********************************************************************
25624       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25625       SAVE
25626
25627       PARAMETER ( Max_pro_2 = 16 )
25628       COMPLEX*16 DSIGMC
25629       DIMENSION DSIGMC(0:Max_pro_2)
25630       PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25631
25632 C  input/output channels
25633       INTEGER LI,LO
25634       COMMON /POINOU/ LI,LO
25635 C  model switches and parameters
25636       CHARACTER*8 MDLNA
25637       INTEGER ISWMDL,IPAMDL
25638       DOUBLE PRECISION PARMDL
25639       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25640 C  data of c.m. system of Pomeron / Reggeon exchange
25641       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25642       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25643      &                 SIDP,CODP,SIFP,COFP
25644       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25645      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25646      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25647 C  Reggeon phenomenology parameters
25648       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25649      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25650       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25651      &                ALREG,ALREGP,GR(2),B0REG(2),
25652      &                GPPP,GPPR,B0PPP,B0PPR,
25653      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25654 C  currently activated parton density parametrizations
25655       CHARACTER*8 PDFNAM
25656       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25657       DOUBLE PRECISION PDFLAM,PDFQ2M
25658       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25659      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25660 C  hard scattering parameters used for most recent hard interaction
25661       INTEGER NFbeta,NF
25662       DOUBLE PRECISION ALQCD2,BQCD
25663       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25664 C  some hadron information, will be deleted in future versions
25665       INTEGER NFS
25666       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25667       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25668 C  scale parameters for parton model calculations
25669       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25670       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25671       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25672      &                NQQAL,NQQALI,NQQALF,NQQPD
25673 C  some constants
25674       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25675       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25676      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25677
25678       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25679       DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25680
25681 *     ONE32=1.D0/9.D0
25682 *     TWO32=4.D0/9.D0
25683       DO 10 I=10,13
25684         DSIGMC(I) = CMPLX(0.D0,0.D0)
25685         DSIGM(I) = 0.D0
25686  10   CONTINUE
25687       DSIGMC(15) = CMPLX(0.D0,0.D0)
25688       DSIGM(15) = 0.D0
25689
25690 C  direct particle 1
25691       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25692         EC     = EXP(ETAC)
25693         ED     = ECMH/PT-EC
25694 C  kinematic conversions
25695         XA     = 1.D0
25696         XB     = 1.D0/(EC*ED)
25697         IF ( XB.GE.1.D0 ) THEN
25698           WRITE(LO,'(/1X,A,2E12.4)')
25699      &      'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25700           RETURN
25701         ENDIF
25702         SP     = XA*XB*ECMH*ECMH
25703         UP     =-ECMH*PT*EC*XB
25704         UP     = UP/SP
25705         TP     =-(1.D0+UP)
25706         UU     = UP*UP
25707         TT     = TP*TP
25708 C  set hard scale  QQ  for alpha and partondistr.
25709         IF     ( NQQAL.EQ.1 ) THEN
25710           QQAL = AQQAL*PT*PT
25711         ELSEIF ( NQQAL.EQ.2 ) THEN
25712           QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25713         ELSEIF ( NQQAL.EQ.3 ) THEN
25714           QQAL = AQQAL*SP
25715         ELSEIF ( NQQAL.EQ.4 ) THEN
25716           QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25717         ENDIF
25718         IF     ( NQQPD.EQ.1 ) THEN
25719           QQPD = AQQPD*PT*PT
25720         ELSEIF ( NQQPD.EQ.2 ) THEN
25721           QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25722         ELSEIF ( NQQPD.EQ.3 ) THEN
25723           QQPD = AQQPD*SP
25724         ELSEIF ( NQQPD.EQ.4 ) THEN
25725           QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25726         ENDIF
25727
25728         ALPHA2 = PHO_ALPHAS(QQAL,2)
25729         IF(IDPDG1.EQ.22) THEN
25730           ALPHA1 = pho_alphae(QQAL)
25731         ELSE IF(IDPDG1.EQ.990) THEN
25732           ALPHA1 = PARMDL(74)
25733         ENDIF
25734         FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25735 C  parton distribution (times x)
25736         CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25737         S1    = PDB(0)
25738 C  charge counting
25739         S2    = 0.D0
25740         S3    = 0.D0
25741         IF(IDPDG1.EQ.22) THEN
25742           DO 20 I=1,NF
25743 *           IF(MOD(I,2).EQ.0) THEN
25744 *             S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25745 *             S3 = S3 + TWO32
25746 *           ELSE
25747 *             S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25748 *             S3 = S3 + ONE32
25749 *           ENDIF
25750             S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25751             S3 = S3 + Q_ch2(I)
25752  20       CONTINUE
25753         ELSE IF(IDPDG1.EQ.990) THEN
25754           DO 25 I=1,NF
25755             S2 = S2 + PDB(I)+PDB(-I)
25756  25       CONTINUE
25757           S3 = NF
25758         ENDIF
25759 C  partial cross sections (including color and symmetry factors)
25760 C  direct photon matrix elements
25761         DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25762         DSIGM(11) = (UU+TT)/(UP*TP)
25763 C
25764         DSIGM(10) = FACTOR*DSIGM(10)*S2
25765         DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25766 C  complex part
25767         X=ABS(TP-UP)
25768         FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25769 C
25770         DO 50 I=10,11
25771           IF(DSIGM(I).LT.0.D0) THEN
25772             WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25773      &        'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25774             DSIGM(I) = 0.D0
25775           ENDIF
25776           DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25777           DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25778  50     CONTINUE
25779       ENDIF
25780 C
25781 C  direct particle 2
25782       IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25783         EC     = EXP(ETAC)
25784         ED     = 1.D0/(ECMH/PT-1.D0/EC)
25785 C  kinematic conversions
25786         XA     = PT*(EC+ED)/ECMH
25787         XB     = 1.D0
25788         IF ( XA.GE.1.D0 ) THEN
25789           WRITE(LO,'(/1X,A,2E12.4)')
25790      &      'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25791           RETURN
25792         ENDIF
25793         SP     = XA*XB*ECMH*ECMH
25794         UP     =-ECMH*PT*EC*XB
25795         UP     = UP/SP
25796         TP     =-(1.D0+UP)
25797         UU     = UP*UP
25798         TT     = TP*TP
25799 C  set hard scale  QQ  for alpha and partondistr.
25800         IF     ( NQQAL.EQ.1 ) THEN
25801           QQAL = AQQAL*PT*PT
25802         ELSEIF ( NQQAL.EQ.2 ) THEN
25803           QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25804         ELSEIF ( NQQAL.EQ.3 ) THEN
25805           QQAL = AQQAL*SP
25806         ELSEIF ( NQQAL.EQ.4 ) THEN
25807           QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25808         ENDIF
25809         IF     ( NQQPD.EQ.1 ) THEN
25810           QQPD = AQQPD*PT*PT
25811         ELSEIF ( NQQPD.EQ.2 ) THEN
25812           QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25813         ELSEIF ( NQQPD.EQ.3 ) THEN
25814           QQPD = AQQPD*SP
25815         ELSEIF ( NQQPD.EQ.4 ) THEN
25816           QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25817         ENDIF
25818
25819         ALPHA1 = PHO_ALPHAS(QQAL,1)
25820         IF(IDPDG2.EQ.22) THEN
25821           ALPHA2 = pho_alphae(QQAL)
25822         ELSE IF(IDPDG2.EQ.990) THEN
25823           ALPHA2 = PARMDL(74)
25824         ENDIF
25825         FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
25826 C  parton distribution (times x)
25827         CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25828         S1    = PDA(0)
25829 C  charge counting
25830         S2    = 0.D0
25831         S3    = 0.D0
25832         IF(IDPDG2.EQ.22) THEN
25833           DO 70 I=1,NF
25834 *           IF(MOD(I,2).EQ.0) THEN
25835 *             S2 = S2 + (PDA(I)+PDA(-I))*TWO32
25836 *             S3 = S3 + TWO32
25837 *           ELSE
25838 *             S2 = S2 + (PDA(I)+PDA(-I))*ONE32
25839 *             S3 = S3 + ONE32
25840 *           ENDIF
25841             S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
25842             S3 = S3 + Q_ch2(I)
25843  70       CONTINUE
25844         ELSE IF(IDPDG2.EQ.990) THEN
25845           DO 75 I=1,NF
25846             S2 = S2 + PDA(I)+PDA(-I)
25847  75       CONTINUE
25848           S3 = NF
25849         ENDIF
25850 C  partial cross sections (including color and symmetry factors)
25851 C  direct photon matrix elements
25852         DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
25853         DSIGM(13) = (UU+TT)/(UP*TP)
25854 C
25855         DSIGM(12) = FACTOR*DSIGM(12)*S2
25856         DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
25857 C  complex part
25858         X=ABS(TP-UP)
25859         FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25860 C
25861         DO 80 I=12,13
25862           IF(DSIGM(I).LT.0.D0) THEN
25863             WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25864      &        'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
25865             DSIGM(I) = 0.D0
25866           ENDIF
25867           DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25868           DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25869  80     CONTINUE
25870       ENDIF
25871       END
25872
25873 CDECK  ID>, PHO_HARXPT
25874       SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
25875 C**********************************************************************
25876 C
25877 C     differential cross section DSIG/DPT
25878 C
25879 C     input:  ECMH     CMS energy of scattering system
25880 C             PT       parton PT
25881 C             IPRO     1  resolved processes
25882 C                      2  direct processes
25883 C                      3  resolved and direct processes
25884 C
25885 C     output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
25886 C
25887 C**********************************************************************
25888       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25889       SAVE
25890
25891       PARAMETER ( Max_pro_2 = 16 )
25892       COMPLEX*16 DSIGMC
25893       DIMENSION  DSIGMC(0:Max_pro_2)
25894       PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
25895
25896 C  input/output channels
25897       INTEGER LI,LO
25898       COMMON /POINOU/ LI,LO
25899 C  some constants
25900       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25901       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25902      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25903 C  model switches and parameters
25904       CHARACTER*8 MDLNA
25905       INTEGER ISWMDL,IPAMDL
25906       DOUBLE PRECISION PARMDL
25907       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25908 C  data of c.m. system of Pomeron / Reggeon exchange
25909       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25910       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25911      &                 SIDP,CODP,SIFP,COFP
25912       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25913      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25914      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25915 C  Reggeon phenomenology parameters
25916       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25917      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25918       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25919      &                ALREG,ALREGP,GR(2),B0REG(2),
25920      &                GPPP,GPPR,B0PPP,B0PPR,
25921      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25922 C  integration precision for hard cross sections (obsolete)
25923       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25924       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25925 C  hard scattering parameters used for most recent hard interaction
25926       INTEGER NFbeta,NF
25927       DOUBLE PRECISION ALQCD2,BQCD
25928       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25929 C  some hadron information, will be deleted in future versions
25930       INTEGER NFS
25931       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25932       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25933
25934       double precision pho_alphae
25935
25936       COMPLEX*16 DSIG1
25937       DIMENSION  DSIG1(0:Max_pro_2)
25938       DIMENSION ABSZ(32),WEIG(32)
25939
25940       DO 10 M=0,Max_pro_2
25941         DSIGMC(M) = CMPLX(0.D0,0.D0)
25942         DSIG1(M)  = CMPLX(0.D0,0.D0)
25943  10   CONTINUE
25944
25945 C  resolved and direct processes
25946       AMT = 2.D0*PT/ECMH
25947       IF ( AMT.GE.1.D0 ) RETURN
25948       ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
25949       ECL = -ECU
25950       NPOINT = NGAUET
25951       CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
25952       DO 30 I=1,NPOINT
25953         DSIG1(9)  = CMPLX(0.D0,0.D0)
25954         DSIG1(15) = CMPLX(0.D0,0.D0)
25955         IF(IPRO.EQ.1) THEN
25956           CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25957         ELSE IF(IPRO.EQ.2) THEN
25958           CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25959         ELSE
25960           CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25961           CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25962         ENDIF
25963         DO 20 M=1,Max_pro_2
25964           DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25965  20     CONTINUE
25966  30   CONTINUE
25967
25968 C  direct processes
25969       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
25970      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
25971         FAC = 0.D0
25972         SS = ECMH*ECMH
25973         ALPHAE = pho_alphae(SS)
25974         DO 300 I=1,NF
25975           IF(IDPDG1.EQ.22) THEN
25976 *           F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25977             F1 = Q_ch2(I)*ALPHAE
25978           ELSE
25979             F1 = PARMDL(74)
25980           ENDIF
25981           IF(IDPDG2.EQ.22) THEN
25982 *           F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25983             F2 = Q_ch2(I)*ALPHAE
25984           ELSE
25985             F2 = PARMDL(74)
25986           ENDIF
25987           FAC = FAC+F1*F2*3.D0
25988  300    CONTINUE
25989 C  direct cross sections
25990         ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
25991         T1 = -SS/2.D0*(1.D0+ZZ)
25992         T2 = -SS/2.D0*(1.D0-ZZ)
25993         XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
25994 C  hadronic part
25995         DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
25996
25997 C  leptonic part (e, mu, tau)
25998         DSIGMC(16) = 0.D0
25999         IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26000           DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
26001 C  simulation of tau together with quarks
26002           IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26003         ENDIF
26004       ENDIF
26005
26006       DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
26007       DSIGMC(0)  = DSIGMC(9)+DSIGMC(15)
26008
26009       END
26010
26011 CDECK  ID>, PHO_HARXTO
26012       SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
26013 C**********************************************************************
26014 C
26015 C     total hard cross section (perturbative QCD, Parton Model)
26016 C
26017 C     input:  ECMH     CMS energy of scattering system
26018 C             PTCUTR   PT cutoff for resolved processes
26019 C             PTCUTD   PT cutoff for direct processes (photon, Pomeron)
26020 C
26021 C     output: DSIGMC(0:MARPR2) cross sections for given cutoff
26022 C             DSDPTC(0:MARPR2) differential cross sections at cutoff
26023 C
26024 C     note:  COMPLEX*16          DSIGMC
26025 C            DOUBLE PRECISION    DSDPTC
26026 C
26027 C**********************************************************************
26028       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26029       SAVE
26030
26031       PARAMETER ( Max_pro_2 = 16 )
26032       COMPLEX*16 DSIGMC
26033       DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
26034
26035 C  input/output channels
26036       INTEGER LI,LO
26037       COMMON /POINOU/ LI,LO
26038 C  model switches and parameters
26039       CHARACTER*8 MDLNA
26040       INTEGER ISWMDL,IPAMDL
26041       DOUBLE PRECISION PARMDL
26042       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26043 C  data of c.m. system of Pomeron / Reggeon exchange
26044       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26045       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26046      &                 SIDP,CODP,SIFP,COFP
26047       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26048      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
26049      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
26050 C  Reggeon phenomenology parameters
26051       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26052      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26053       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26054      &                ALREG,ALREGP,GR(2),B0REG(2),
26055      &                GPPP,GPPR,B0PPP,B0PPR,
26056      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26057 C  some constants
26058       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26059       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26060      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26061 C  integration precision for hard cross sections (obsolete)
26062       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26063       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26064 C  some hadron information, will be deleted in future versions
26065       INTEGER NFS
26066       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26067       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26068 C  hard scattering parameters used for most recent hard interaction
26069       INTEGER NFbeta,NF
26070       DOUBLE PRECISION ALQCD2,BQCD
26071       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26072
26073       double precision pho_alphae
26074
26075       COMPLEX*16 DSIG1
26076       DIMENSION DSIG1(0:Max_pro_2)
26077       DIMENSION ABSZ(32),WEIG(32)
26078
26079       DATA FAC / 3.0D0 /
26080
26081       DO 10 M=0,Max_pro_2
26082         DSIGMC(M)= CMPLX(0.D0,0.D0)
26083  10   CONTINUE
26084       EEC=ECMH/2.001D0
26085 C
26086       IF ( PTCUTR.GE.EEC ) GOTO 100
26087 C
26088 C  integration for resolved processes
26089       PTMIN  = PTCUTR
26090       PTMAX  = MIN(FAC*PTMIN,EEC)
26091       NPOINT = NGAUP1
26092       CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26093       DO 60 M=1,9
26094         DSDPTC(M) = DREAL(DSIG1(M))
26095  60   CONTINUE
26096       DSIGH   = DREAL(DSIG1(9))
26097       PTMXX  = 0.95D0*PTMAX
26098       CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26099       DSIGL  = DREAL(DSIG1(9))
26100       EX     = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26101       EX1    = 1.0D0-EX
26102       DO 50 K=1,2
26103         IF ( PTMIN.GE.PTMAX ) GOTO 40
26104         RL   = PTMIN**EX1
26105         RU   = PTMAX**EX1
26106         CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26107         DO 30 I=1,NPOINT
26108           R  = ABSZ(I)
26109           PT = R**(1.0D0/EX1)
26110           CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26111           F  = WEIG(I)*PT/(R*EX1)
26112           DO 20 M=1,9
26113             DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26114  20       CONTINUE
26115  30     CONTINUE
26116  40     PTMIN  = PTMAX
26117         PTMAX  = EEC
26118         NPOINT = NGAUP2
26119  50   CONTINUE
26120  100  CONTINUE
26121       DSIGMC(0) = DSIGMC(9)
26122       DSDPTC(0) = DSDPTC(9)
26123 C
26124 C  integration for direct processes
26125       IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26126 C
26127       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26128      &   .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26129         PTMIN  = PTCUTD
26130         PTMAX  = MIN(FAC*PTMIN,EEC)
26131         NPOINT = NGAUP1
26132         CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26133         IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26134         DO 160 M=10,16
26135           DSDPTC(M) = DREAL(DSIG1(M))
26136  160    CONTINUE
26137         DSIGH   = DREAL(DSIG1(15)-DSIG1(14))
26138         PTMXX  = 0.95D0*PTMAX
26139         CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26140         DSIGL  = DREAL(DSIG1(15)-DSIG1(14))
26141         EX     = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26142         EX1    = 1.0D0-EX
26143         DO 150 K=1,2
26144           IF ( PTMIN.GE.PTMAX ) GOTO 140
26145           RL   = PTMIN**EX1
26146           RU   = PTMAX**EX1
26147           CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26148           DO 130 I=1,NPOINT
26149             R  = ABSZ(I)
26150             PT = R**(1.0D0/EX1)
26151             CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26152             F  = WEIG(I)*PT/(R*EX1)
26153             DO 120 M=10,15
26154               DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26155  120        CONTINUE
26156  130      CONTINUE
26157  140      PTMIN  = PTMAX
26158           PTMAX  = EEC
26159           NPOINT = NGAUP2
26160  150    CONTINUE
26161       ENDIF
26162 C
26163  170  CONTINUE
26164 C
26165 C  double direct process
26166       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26167      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26168         FACC = 0.D0
26169         SS = ECMH*ECMH
26170         ALPHAE = pho_alphae(SS)
26171         DO 300 I=1,NF
26172           IF(IDPDG1.EQ.22) THEN
26173 *           F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26174             F1 = Q_ch2(I)*ALPHAE
26175           ELSE
26176             F1 = PARMDL(74)
26177           ENDIF
26178           IF(IDPDG2.EQ.22) THEN
26179 *           F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26180             F2 = Q_ch2(I)*ALPHAE
26181           ELSE
26182             F2 = PARMDL(74)
26183           ENDIF
26184           FACC = FACC + F1*F2*3.D0
26185  300    CONTINUE
26186
26187         ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26188         R  = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26189 C  hadronic cross section
26190         DSIGMC(14) = R*FACC*AKFAC
26191 C  leptonic cross section
26192         IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26193           DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26194 C  simulation of tau together with quarks
26195           IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26196           DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26197         ELSE
26198           DSIGMC(16) = CMPLX(0.D0,0.D0)
26199         ENDIF
26200 C  sum of direct part
26201         DSIGMC(15) = CMPLX(0.D0,0.D0)
26202         DO 400 I=10,14
26203           DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26204  400    CONTINUE
26205       ENDIF
26206 C total sum (hadronic)
26207       DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26208       DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26209
26210       END
26211
26212 CDECK  ID>, PHO_HARISR
26213       SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26214      &  XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26215 C********************************************************************
26216 C
26217 C     initial state radiation according to DGLAP evolution equations
26218 C     (backward evolution, no spin effects)
26219 C
26220 C     input:    IHPOM     index of hard Pomeron
26221 C                         negative: delete all previous entries
26222 C               P1,P2     4 momenta of hard scattered final partons
26223 C                         (in CMS of hard scattering)
26224 C               IPF1,2    flavours of final partons
26225 C               IPA1,2    flavours of initial partons
26226 C               IV1,2     valence quark labels (0/1)
26227 C               Q2H       momentum transfer (squared, positive)
26228 C               XH1,XH2   x values of initial partons
26229 C               XHMAX1,2  max. x values allowed
26230 C
26231 C     output:   all emitted partons in /POPISR/, final state
26232 C               partons are the first two entries
26233 C               shower evolution traced in /PODGL1/
26234 C               IPB1,2    flavours of new initial partons
26235 C               XISR1,2   x values of new initial partons
26236 C               IVO1,2    valence quark labels (0/1)
26237 C
26238 C     attention: quark numbering according to PDG convention,
26239 C                but 0 for gluons
26240 C
26241 C********************************************************************
26242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26243       SAVE
26244
26245       PARAMETER (RHOMAS =  0.766D0,
26246      &           DEPS   =  1.D-10,
26247      &           TINY   =  1.D-10)
26248
26249       DIMENSION P1(4),P2(4)
26250
26251 C  input/output channels
26252       INTEGER LI,LO
26253       COMMON /POINOU/ LI,LO
26254 C  event debugging information
26255       INTEGER NMAXD
26256       PARAMETER (NMAXD=100)
26257       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26258      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26259       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26260      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26261 C  internal rejection counters
26262       INTEGER NMXJ
26263       PARAMETER (NMXJ=60)
26264       CHARACTER*10 REJTIT
26265       INTEGER IFAIL
26266       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26267 C  model switches and parameters
26268       CHARACTER*8 MDLNA
26269       INTEGER ISWMDL,IPAMDL
26270       DOUBLE PRECISION PARMDL
26271       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26272 C  data of c.m. system of Pomeron / Reggeon exchange
26273       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26274       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26275      &                 SIDP,CODP,SIFP,COFP
26276       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26277      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
26278      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
26279 C  some hadron information, will be deleted in future versions
26280       INTEGER NFS
26281       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26282       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26283 C  currently activated parton density parametrizations
26284       CHARACTER*8 PDFNAM
26285       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26286       DOUBLE PRECISION PDFLAM,PDFQ2M
26287       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26288      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26289 C  scale parameters for parton model calculations
26290       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26291       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26292       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26293      &                NQQAL,NQQALI,NQQALF,NQQPD
26294 C  parameters for DGLAP backward evolution in ISR
26295       INTEGER NFSISR
26296       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26297       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26298 C  initial state parton radiation (internal part)
26299       INTEGER MXISR3,MXISR4
26300       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26301       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26302       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26303       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26304      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26305      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
26306      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26307 C  some constants
26308       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26309       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26310      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26311 C  particles created by initial state evolution
26312       INTEGER MXISR1,MXISR2
26313       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26314       INTEGER IFLISR,IPOISR,IMXISR
26315       DOUBLE PRECISION PHISR
26316       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26317      &                IPOISR(2,2,MXISR2),IMXISR(2)
26318
26319       DOUBLE PRECISION PYP,EER,THER,QMAXR
26320       INTEGER PYK
26321
26322       DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26323      &          WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26324      &          IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26325
26326       IREJ = 0
26327       NTRY = 1000
26328       NITER = 0
26329 C  debug output
26330       IF(IDEB(79).GE.10) THEN
26331         WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26332      &    'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26333      &    KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26334       ENDIF
26335       IF(IHPOM.EQ.0) RETURN
26336 C
26337  10   CONTINUE
26338       NACC = 0
26339       IDMO(1) = IDPDG1
26340       IDMO(2) = IDPDG2
26341 C
26342 C  copy final state partons to local fields
26343       IHIDX = ABS(IHPOM)
26344
26345       IF(IHIDX.GT.MXISR2) THEN
26346         WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26347      &    '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26348      &    IHIDX,MXISR2
26349         IREJ = 1
26350       ENDIF
26351
26352       DO 50 K=1,2
26353         IF(IHPOM.LT.0) IMXISR(K) = 0
26354         IPOISR(K,1,IHIDX) = IMXISR(K)+1
26355         IPAL(K) = IPOISR(K,1,IHIDX)
26356  50   CONTINUE
26357       DO 55 I=1,4
26358         PHISR(1,I,IPAL(1)) = P1(I)
26359         PHISR(2,I,IPAL(2)) = P2(I)
26360  55   CONTINUE
26361       IFLISR(1,IPAL(1)) = IPF1
26362       IFLISR(2,IPAL(2)) = IPF2
26363 C
26364 C  check limitations, initialize /PODGL1/
26365       IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26366         NEXT(1) = 1
26367         Q2SH(1,1) = Q2H
26368       ELSE
26369         NEXT(1) = 0
26370         Q2SH(1,1) = 0.D0
26371       ENDIF
26372       IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26373         NEXT(2) = 1
26374         Q2SH(2,1) = Q2H
26375       ELSE
26376         NEXT(2) = 0
26377         Q2SH(2,1) = 0.D0
26378       ENDIF
26379 C
26380       ISH(1) = 1
26381       ISH(2) = 1
26382       XPSH(1,1) = XH1
26383       XPSH(2,1) = XH2
26384 C
26385       IFL1(1,1) = IPA1
26386       IVAL(1)   = IV1
26387       IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26388       IFL1(2,1) = IPA2
26389       IVAL(2)   = IV2
26390       IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26391 C
26392       IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26393      &  'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26394       IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26395 C
26396 C  initialize parton shower loop
26397       B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26398       AL2ISR(1) = PDFLAM(1)
26399       AL2ISR(2) = PDFLAM(2)
26400       XHMA(1) = XHMAX1
26401       XHMA(2) = XHMAX2
26402       XHMI(1) = PMISR(1)/PCMP
26403       XHMI(2) = PMISR(2)/PCMP
26404       ZPSH(1,1) = 1.D0
26405       ZPSH(2,1) = 1.D0
26406       SHAT1 = XH1*XH2*ECMP**2
26407       IF(IPAMDL(109).EQ.1) THEN
26408         PT2SH(1,1) = Q2H
26409       ELSE
26410         PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26411       ENDIF
26412       PT2SH(2,1) = PT2SH(1,1)
26413       IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26414       IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26415       THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26416       THSH(2,1) = THSH(1,1)
26417       IFANO(1) = 0
26418       IFANO(2) = 0
26419       ZZ = 1.D0
26420       IF(IREJ.NE.0) GOTO 800
26421 C
26422 C  main generation loop
26423 C -------------------------------------------------
26424  100  CONTINUE
26425 C  choose parton side to become solved
26426         IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26427           IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26428             IP = 1
26429           ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26430             IP = 2
26431           ELSE
26432             IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26433           ENDIF
26434         ELSE IF(NEXT(1).EQ.1) THEN
26435           IP = 1
26436         ELSE IF(NEXT(2).EQ.1) THEN
26437           IP = 2
26438         ELSE
26439           GOTO 800
26440         ENDIF
26441         INDX = ISH(IP)
26442 C  INDX now parton position of parton to become solved
26443 C  IP   now side to be treated
26444         XP = XPSH(IP,INDX)
26445         Q2P = Q2SH(IP,INDX)
26446         PT2 = PT2SH(IP,INDX)
26447         IFLB = IFL1(IP,INDX)
26448 C  check available x
26449         XMIP = XHMI(IP)
26450 C  cutoff by x limitation: no further development
26451         IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26452           NEXT(IP) = 0
26453           Q2SH(IP,INDX) = 0.D0
26454           IF(IDEB(79).GE.17) THEN
26455             WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26456      &        'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26457      &        XP,XMIP,XHMA(IP),IP,INDX
26458           ENDIF
26459           GOTO 100
26460         ENDIF
26461 C  initial value of evolution variable t
26462         TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26463         DO 110 I=-NFSISR,NFSISR
26464           WGGAP(I) = 0.D0
26465           WGPDF(I) = 0.D0
26466  110    CONTINUE
26467 C  DGLAP weights
26468         ZMIN = XP/XHMA(IP)
26469         ZMAX = XP/(XP+XMIP)
26470         CF = 4./3.
26471 C  q --> q g, g --> g g
26472         IF(IFLB.EQ.0) THEN
26473           WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26474      &      +2.D0*LOG(ZMAX/ZMIN))
26475           DO 120 I=1,NFSISR
26476             WGGAP(I)  = WGGAP(0)
26477             WGGAP(-I) = WGGAP(0)
26478  120      CONTINUE
26479           WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26480      &      -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26481 C  q --> g q, g --> q qb
26482         ELSE IF(ABS(IFLB).LE.6) THEN
26483           WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26484      &      -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26485           IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26486      &      -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26487         ELSE
26488           WRITE(LO,'(/1X,A,I7)')
26489      &      'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26490           CALL PHO_ABORT
26491         ENDIF
26492 C  anomalous/resolved evolution
26493         IPDFC = 0
26494         IF(IPAMDL(110).GE.1) THEN
26495           IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26496      &       .AND.(IFLB.NE.21)) THEN
26497             WGDIR = 0.D0
26498             IF(NQQALI.EQ.1) THEN
26499               SCALE2 = PT2*AQQPD
26500             ELSE
26501               SCALE2 = Q2P*AQQPD
26502             ENDIF
26503             CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26504             IPDFC = 1
26505             CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26506             XI = DT_RNDM(XP)*PD1(IFLB)
26507             IF(WGDIR.GT.XI) THEN
26508 C  debug output
26509               IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26510      &          'PHO_HARISR: ',
26511      &          'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26512      &          WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26513               Q2SH(IP,INDX) = 0.D0
26514               NEXT(IP) = 0
26515               IFANO(IP) = INDX
26516               GOTO 100
26517             ENDIF
26518           ENDIF
26519         ENDIF
26520 C
26521 C  rejection loop for z,t sampling
26522 C ------------------------------------
26523  200    CONTINUE
26524           NITER = NITER+1
26525           IF(NITER.GE.NTRY) THEN
26526             WRITE(LO,'(1X,A,2I6)')
26527      &        'PHO_HARISR: too many rejections',NITER,NTRY
26528             CALL PHO_PREVNT(-1)
26529 C  clean up event
26530             IREJ = 1
26531             GOTO 10
26532           ENDIF
26533 C  PDF weights
26534           IF(IPDFC.EQ.0) THEN
26535             IF(NQQALI.EQ.1) THEN
26536               SCALE2 = PT2*AQQPD
26537             ELSE
26538               SCALE2 = Q2P*AQQPD
26539             ENDIF
26540             CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26541           ENDIF
26542           IPDFC = 0
26543 C
26544           WGTOT = 0.D0
26545           DO 210 I=-NFSISR,NFSISR
26546             WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26547             WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26548  210      CONTINUE
26549 C
26550  215      CONTINUE
26551 C  sample new t value
26552           TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26553           Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26554 C  debug output
26555           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26556      &      'PHO_HARISR: pre-selected Q2:',Q2NEW
26557 C  compare to limits
26558           IF(Q2NEW.LT.Q2MISR(IP)) THEN
26559             Q2SH(IP,INDX) = 0.D0
26560             NEXT(IP) = 0
26561             IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26562      &        'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26563      &        Q2NEW,Q2MISR(IP),IP,INDX
26564             GOTO 100
26565           ENDIF
26566           Q2SH(IP,INDX) = Q2NEW
26567           TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26568 C  selection of flavours
26569           XI = WGTOT*DT_RNDM(TT)
26570           IFLA = -NFSISR-1
26571  220      CONTINUE
26572             IFLA = IFLA+1
26573             XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26574           IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26575 C  debug output
26576           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26577      &      'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26578 C  selection of z
26579           CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26580 C  debug output
26581           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26582      &      'PHO_HARISR: pre-selected ZZ',ZZ
26583 C  angular ordering
26584           THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26585           IF(THETA.GT.THSH(IP,INDX)) THEN
26586             IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26587      &        'PHO_HARISR: reject by angle (NEW/OLD)',
26588      &        THETA,THSH(IP,INDX)
26589             GOTO 215
26590           ENDIF
26591 C  rejection weight given by new PDFs
26592           XNEW = XP/ZZ
26593           PT2NEW = Q2NEW*(1.D0-ZZ)
26594           IF(NQQALI.EQ.1) THEN
26595             SCALE2 = PT2NEW*AQQPD
26596           ELSE
26597             SCALE2 = Q2NEW*AQQPD
26598           ENDIF
26599           IF(SCALE2.LT.Q2MISR(IP)) THEN
26600             Q2SH(IP,INDX) = 0.D0
26601             NEXT(IP) = 0
26602             IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26603      &        'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26604      &        Q2NEW,Q2MISR(IP),IP,INDX
26605             GOTO 100
26606           ENDIF
26607           CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26608           IF(PD2(IFLA).LT.1.D-10) GOTO 200
26609           CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26610           PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26611           WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26612           IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26613      &      /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26614           IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26615             WRITE(LO,'(1X,A,E12.3)')
26616      &        'PHO_HARISR: final weight:',WGF
26617             WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26618      &      'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26619           ENDIF
26620         IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26621
26622         IF(IDEB(79).GE.15) THEN
26623           WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26624      &      'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26625      &      IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26626         ENDIF
26627
26628         IF(INDX.GE.MXISR3) THEN
26629           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26630      &      '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26631           IREJ = 1
26632           RETURN
26633         ENDIF
26634
26635 C  branching accepted, registration
26636         Q2SH(IP,INDX) = Q2NEW
26637         PT2SH(IP,INDX) = PT2NEW
26638         ZPSH(IP,INDX) = ZZ
26639         IFL2(IP,INDX) = IFLA-IFLB
26640         Q2SH(IP,INDX+1) = Q2NEW
26641         PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26642         XPSH(IP,INDX+1) = XNEW
26643         THSH(IP,INDX+1) = THETA
26644         IFL1(IP,INDX+1) = IFLA
26645         ISH(IP) = ISH(IP)+1
26646
26647         NACC = NACC+1
26648
26649         IF(NACC.GT.MXISR4) THEN
26650           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26651      &      '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26652           IREJ = 1
26653           RETURN
26654         ENDIF
26655
26656         SHAT(NACC) = SHAT1
26657         IBRA(1,NACC) = IP
26658         IBRA(2,NACC) = INDX
26659         SHAT1 = SHAT1/ZZ
26660
26661 C  generation of next branching
26662       IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26663
26664  800  CONTINUE
26665
26666 C  new initial flavours, x values
26667       IPB1 = IFL1(1,ISH(1))
26668       IPB2 = IFL1(2,ISH(2))
26669       XISR1 = XPSH(1,ISH(1))
26670       XISR2 = XPSH(2,ISH(2))
26671       IVO1  = IVAL(1)
26672       IVO2  = IVAL(2)
26673 C  valence flavours
26674       IF(IPB1.NE.0) THEN
26675         IF(ISH(1).GT.1) THEN
26676           CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26677           IF(IDPDG1.EQ.22) THEN
26678             CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26679             IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26680           ELSE
26681             CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26682             IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26683           ENDIF
26684         ENDIF
26685       ENDIF
26686       IF(IPB2.NE.0) THEN
26687         IF(ISH(2).GT.1) THEN
26688           CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26689           IF(IDPDG2.EQ.22) THEN
26690             CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26691             IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26692           ELSE
26693             IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26694           ENDIF
26695         ENDIF
26696       ENDIF
26697
26698 C  parton kinematics
26699       IF(NACC.GT.0) THEN
26700 C  final partons in CMS
26701         PM(3) = (XH1-XH2)*ECMP/2.D0
26702         PM(4) = (XH1+XH2)*ECMP/2.D0
26703         SH = XH1*XH2*ECMP**2
26704         SSH = SQRT(SH)
26705         GB(3) = PM(3)/SSH
26706         GB(4) = PM(4)/SSH
26707         CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26708      &    P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26709      &    PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26710         CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26711      &    P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26712      &    PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26713         IL(1) = 1
26714         IL(2) = 1
26715         DO 900 I=1,NACC
26716           IPA = IBRA(1,I)
26717           IPB = 3-IPA
26718           IL(IPA) = IBRA(2,I)
26719 C  new initial partons in CMS
26720           SH = SHAT(I)
26721           SSH = SQRT(SH)
26722           SHZ = SH/ZPSH(IPA,IL(IPA))
26723           SSHZ = SQRT(SHZ)
26724           Q2(1) = Q2SH(1,IL(1))
26725           Q2(2) = Q2SH(2,IL(2))
26726           PC(1,1) = 0.D0
26727           PC(1,2) = 0.D0
26728           PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26729      &             /(2.D0*SSH)
26730           PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26731           PC(2,1) = 0.D0
26732           PC(2,2) = 0.D0
26733           PC(2,3) = -PC(1,3)
26734           PC(2,4) = SSH-PC(1,4)
26735           XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26736           EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26737           S1 = SH+Q2(IPA)+Q2(IPB)
26738           S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26739           R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26740           R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26741           IF(Q2(IPB).LT.0.1D0) THEN
26742             XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26743      &             *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26744           ELSE
26745             XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26746      &             -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26747           ENDIF
26748           NGEN = 1
26749 C  max. virtuality for time-like showers
26750           QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26751           IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26752 C  generate time-like parton shower
26753             KF = IFL2(IPA,IL(IPA))
26754             IF(KF.EQ.0) KF = 21
26755             EER = MIN(EE3-PC(IPA,4),ECMP)
26756             THER = 0.
26757
26758             CALL PY1ENT(1,KF,EER,THER,THER)
26759             QMAXR = SQRT(QMAX)
26760             CALL PYSHOW(1,0,QMAXR)
26761 C debug output
26762             IF(IDEB(79).GE.25) THEN
26763               WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26764      &          'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26765      &          EER,QMAX,XMS4M,Q2(IPA)
26766               CALL PYLIST(1)
26767             ENDIF
26768             NGEN = PYK(0,1)
26769
26770             IF(NGEN.GT.1) THEN
26771               PJX = 0.D0
26772               PJY = 0.D0
26773               PJZ = 0.D0
26774               PJE = 0.D0
26775               KK = IPAL(IPA)
26776               DO 820 K=3,NGEN
26777
26778                 IF(PYK(K,1).LE.4) THEN
26779                   KK = KK+1
26780
26781                   IF(KK.GT.MXISR1) THEN
26782                     WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26783      &                'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26784                     IREJ = 1
26785                     RETURN
26786                   ENDIF
26787
26788                   PHISR(IPA,1,KK) = PYP(K,1)
26789                   PJX = PJX+PHISR(IPA,1,KK)
26790                   PHISR(IPA,2,KK) = PYP(K,2)
26791                   PJY = PJY+PHISR(IPA,2,KK)
26792                   PHISR(IPA,3,KK) = PYP(K,3)
26793                   PJZ = PJZ+PHISR(IPA,3,KK)
26794                   PHISR(IPA,4,KK) = PYP(K,4)
26795                   PJE = PJE+PHISR(IPA,4,KK)
26796                   IFLISR(IPA,KK)  = PYK(K,2)
26797
26798                   IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26799                   IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26800                   IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26801                 ENDIF
26802  820          CONTINUE
26803               NGEN = KK-IPAL(IPA)
26804               XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26805               PP4  = SQRT(PJE**2-XMS4)
26806               EE3  = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26807 C debug output
26808               IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26809      &         'PHO_HARISR: ',
26810      &         'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26811      &         PJE,PJX,PJY,PJZ,PP4,XMS4
26812             ENDIF
26813           ENDIF
26814           PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26815      &          /(2.D0*PC(IPA,3))
26816           PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26817           IF(PT3.LT.0.D0) THEN
26818             IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
26819      &        'PHO_HARISR: rejection due to PT3',PT3
26820             GOTO 10
26821           ENDIF
26822           PT3 = SQRT(PT3)
26823           CALL PHO_SFECFE(SFE,CFE)
26824           PX3 = CFE*PT3
26825           PY3 = SFE*PT3
26826 C
26827           IF(NGEN.GT.1) THEN
26828 C  time-like shower generated
26829             EE4 = EE3-PC(IPA,4)
26830             PZ4 = PZ3-PC(IPA,3)
26831             PP4 = SQRT(PT3**2+PZ4**2)
26832 C  Lorentz boost
26833             GAM = (EE4*PJE-PP4*PJZ)/XMS4
26834             BEG = (PJE*PP4-EE4*PJZ)/XMS4
26835 C  rotation angles
26836             CODD = PZ4/PP4
26837             SIDD = SQRT(PX3**2+PY3**2)/PP4
26838             COFD = 1.D0
26839             SIFD = 0.D0
26840             IF(PP4*SIDD.GT.1.D-5) THEN
26841               COFD = PX3/(SIDD*PP4)
26842               SIFD = PY3/(SIDD*PP4)
26843               ANORF = SQRT(COFD*COFD+SIFD*SIFD)
26844               COFD = COFD/ANORF
26845               SIFD = SIFD/ANORF
26846             ENDIF
26847 C  copy partons back
26848             KK = IPAL(IPA)
26849             DO 830 K=1,NGEN
26850               KK = KK+1
26851               PX = PHISR(IPA,1,KK)
26852               PY = PHISR(IPA,2,KK)
26853               PZ = PHISR(IPA,3,KK)
26854               COH= PHISR(IPA,4,KK)
26855               EE = GAM*COH+BEG*PZ
26856               PZ = GAM*PZ +BEG*COH
26857               PHISR(IPA,4,KK) = EE
26858               CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
26859      &          PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
26860  830        CONTINUE
26861             IPAL(IPA) = KK
26862           ELSE
26863 C  no time-like shower generated
26864             IPAL(IPA) = IPAL(IPA)+1
26865             PHISR(IPA,1,IPAL(IPA)) = PX3
26866             PHISR(IPA,2,IPAL(IPA)) = PY3
26867             PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
26868             PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
26869             IFLISR(IPA,IPAL(IPA))  = IFL2(IPA,IL(IPA))
26870           ENDIF
26871           PC(IPA,1) = PX3
26872           PC(IPA,2) = PY3
26873           PC(IPA,3) = PZ3
26874           PC(IPA,4) = EE3
26875 C  boost / rotate into new CMS
26876           DO 842 K=1,4
26877             GB(K) = (PC(1,K)+PC(2,K))/SSHZ
26878  842      CONTINUE
26879           CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
26880      &      PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
26881           COG= PM(3)/PTOT1
26882           SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
26883           COH=1.D0
26884           SIH=0.D0
26885           IF(PTOT1*SIG.GT.1.D-5) THEN
26886             COH=PM(1)/(SIG*PTOT1)
26887             SIH=PM(2)/(SIG*PTOT1)
26888             ANORF=SQRT(COH*COH+SIH*SIH)
26889             COH=COH/ANORF
26890             SIH=SIH/ANORF
26891           ENDIF
26892           DO 845 K=1,2
26893             DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
26894               CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
26895      &          PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
26896      &          PTOT1,PM(1),PM(2),PM(3),PM(4))
26897               CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
26898      &          PN(2),PN(3))
26899               CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
26900      &          PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
26901               PHISR(K,4,L) = PM(4)
26902  844        CONTINUE
26903  845      CONTINUE
26904  900    CONTINUE
26905 C  boost back to global CMS
26906         PM(3) = (XISR1-XISR2)/2.D0
26907         PM(4) = (XISR1+XISR2)/2.D0
26908         SSH = SQRT(XISR1*XISR2)
26909         GB(3) = PM(3)/SSH
26910         GB(4) = PM(4)/SSH
26911         DO 945 K=1,2
26912           DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
26913             CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
26914      &        PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
26915      &        PM(2),PM(3),PM(4))
26916             PHISR(K,1,L) = PM(1)
26917             PHISR(K,2,L) = PM(2)
26918             PHISR(K,3,L) = PM(3)
26919             PHISR(K,4,L) = PM(4)
26920  944      CONTINUE
26921  945    CONTINUE
26922       ENDIF
26923       IPOISR(1,2,IHIDX) = IPAL(1)
26924       IPOISR(2,2,IHIDX) = IPAL(2)
26925       IMXISR(1) = IPAL(1)
26926       IMXISR(2) = IPAL(2)
26927 C
26928 C  debug output
26929       IF(IDEB(79).GE.10) THEN
26930         WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
26931      &    ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
26932         IF(NACC.GT.0) THEN
26933           WRITE(LO,'(1X,A,2I5,/6X,A)')
26934      &    'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
26935      &    ' SIDE   NO.   IFLB IFLC     Q2SH    PT2SH     XH         ZZ'
26936           DO 600 II=1,NACC
26937             K = IBRA(1,II)
26938             I = IBRA(2,II)
26939             WRITE(LO,'(5X,4I5,4E11.3)')
26940      &        K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
26941      &        ZPSH(K,I)
26942  600      CONTINUE
26943         ENDIF
26944 C  check of final configuration
26945         PX3 = 0.D0
26946         PY3 = 0.D0
26947         PZ3 = 0.D0
26948         EE3 = 0.D0
26949         IFSUM(1) = 0
26950         IFSUM(2) = 0
26951         WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
26952         DO 745 K=1,2
26953           DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
26954             WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
26955      &        PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
26956             IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
26957             PX3 = PX3 + PHISR(K,1,L)
26958             PY3 = PY3 + PHISR(K,2,L)
26959             PZ3 = PZ3 + PHISR(K,3,L)
26960             EE3 = EE3 + PHISR(K,4,L)
26961  744      CONTINUE
26962  745    CONTINUE
26963         IFSUM(1) = IFSUM(1)-IPB1
26964         IFSUM(2) = IFSUM(2)-IPB2
26965         PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
26966         EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
26967         WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
26968      &    IFSUM,PX3,PY3,PZ3,EE3
26969       ENDIF
26970       END
26971
26972 CDECK  ID>, PHO_HARZSP
26973       SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
26974 C*********************************************************************
26975 C
26976 C     sampling of z values from DGLAP kernels
26977 C
26978 C     input:  IFLA,IFLB      parton flavours
26979 C             NFSH           flavours involved in hard processes
26980 C             ZMIN           minimal ZZ allowed
26981 C             ZMAX           maximal ZZ allowed
26982 C
26983 C     output: ZZ             z value
26984 C
26985 C*********************************************************************
26986       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26987       SAVE
26988
26989       PARAMETER ( DEPS   =  1.D-10 )
26990
26991 C  input/output channels
26992       INTEGER LI,LO
26993       COMMON /POINOU/ LI,LO
26994 C  event debugging information
26995       INTEGER NMAXD
26996       PARAMETER (NMAXD=100)
26997       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26998      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26999       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27000      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27001 C  internal rejection counters
27002       INTEGER NMXJ
27003       PARAMETER (NMXJ=60)
27004       CHARACTER*10 REJTIT
27005       INTEGER IFAIL
27006       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27007
27008       IF(ZMAX.LE.ZMIN) THEN
27009         WRITE(LO,'(1X,A,2E12.3)')
27010      &    'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
27011         CALL PHO_PREVNT(-1)
27012         ZZ = 0.D0
27013         RETURN
27014       ENDIF
27015 C
27016       IF(IFLB.EQ.0) THEN
27017         IF(IFLA.EQ.0) THEN
27018 C  g --> g g
27019           C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
27020           C2 = (1.D0-ZMIN)/ZMIN
27021  100      CONTINUE
27022             ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
27023           IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
27024         ELSE IF(ABS(IFLA).LE.NFSH) THEN
27025 C  q --> q g
27026           C1 = ZMAX/ZMIN
27027  200      CONTINUE
27028             ZZ = ZMIN*C1**DT_RNDM(ZMIN)
27029           IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
27030         ELSE
27031           GOTO 900
27032         ENDIF
27033       ELSE IF(ABS(IFLB).LE.NFSH) THEN
27034         IF(IFLA.EQ.0) THEN
27035 C  g --> q qb
27036           C1 = ZMAX-ZMIN
27037  300      CONTINUE
27038             ZZ = ZMIN+C1*DT_RNDM(ZMIN)
27039           IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
27040         ELSE IF(ABS(IFLA).LE.NFSH) THEN
27041 C  q --> g q
27042           C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
27043           C2 = 1.D0-ZMIN
27044  400      CONTINUE
27045             ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
27046           IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
27047         ELSE
27048           GOTO 900
27049         ENDIF
27050       ELSE
27051         GOTO 900
27052       ENDIF
27053 C  debug output
27054       IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
27055      &  'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
27056      &  IFLA,IFLB,ZZ,ZMIN,ZMAX
27057       RETURN
27058
27059  900  CONTINUE
27060       WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
27061      &  IFLA,IFLB
27062       CALL PHO_ABORT
27063
27064       END
27065
27066 CDECK  ID>, PHO_ALPHAE
27067       DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
27068 C**********************************************************************
27069 C
27070 C     calculation of ALPHA_em
27071 C
27072 C     input:    Q2      scale in GeV**2
27073 C
27074 C**********************************************************************
27075
27076       IMPLICIT NONE
27077
27078       SAVE
27079
27080       DOUBLE PRECISION Q2
27081
27082 C  input/output channels
27083       INTEGER LI,LO
27084       COMMON /POINOU/ LI,LO
27085 C  model switches and parameters
27086       CHARACTER*8 MDLNA
27087       INTEGER ISWMDL,IPAMDL
27088       DOUBLE PRECISION PARMDL
27089       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27090
27091       DOUBLE PRECISION PYALEM
27092
27093       pho_alphae = 1.D0/137.D0
27094
27095       if(ipamdl(120).eq.1) then
27096
27097         pho_alphae = PYALEM(Q2)
27098
27099       endif
27100
27101       END
27102
27103 CDECK  ID>, PHO_ALPHAS
27104       DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27105 C**********************************************************************
27106 C
27107 C     calculation of ALPHA_S
27108 C
27109 C     input:    IMODE = 1         lambda_QCD**2 for PDF 1 evolution
27110 C                       2         lambda_QCD**2 for PDF 2 evolution
27111 C                       3         lambda_QCD**2 for hard scattering
27112 C               Q2      scale in GeV**2
27113 C
27114 C     initialization needed:
27115 C               IMODE = 0         lambda values taken from PDF table
27116 C                       -1        given Q2 is 4-flavour lambda 1
27117 C                       -2        given Q2 is 4-flavour lambda 2
27118 C                       -3        given Q2 is 4-flavour lambda 3
27119 C
27120 C
27121 C**********************************************************************
27122
27123       IMPLICIT NONE
27124
27125       SAVE
27126
27127       DOUBLE PRECISION Q2
27128       INTEGER IMODE
27129
27130 C  input/output channels
27131       INTEGER LI,LO
27132       COMMON /POINOU/ LI,LO
27133 C  model switches and parameters
27134       CHARACTER*8 MDLNA
27135       INTEGER ISWMDL,IPAMDL
27136       DOUBLE PRECISION PARMDL
27137       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27138 C  hard scattering parameters used for most recent hard interaction
27139       INTEGER NFbeta,NF
27140       DOUBLE PRECISION ALQCD2,BQCD
27141       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27142 C  currently activated parton density parametrizations
27143       CHARACTER*8 PDFNAM
27144       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27145       DOUBLE PRECISION PDFLAM,PDFQ2M
27146       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27147      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27148
27149       INTEGER I
27150
27151       PHO_ALPHAS = 0.D0
27152
27153       IF(IMODE.GT.0) THEN
27154
27155         IF(Q2.LT.PARMDL(148)) THEN
27156           NFbeta = 1
27157         ELSE IF(Q2.LT.PARMDL(149)) THEN
27158           NFbeta = 2
27159         ELSE IF(Q2.LT.PARMDL(150)) THEN
27160           NFbeta = 3
27161         ELSE
27162           NFbeta = 4
27163         ENDIF
27164
27165         PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27166         NFbeta = NFbeta+2
27167
27168       ELSE IF(IMODE.EQ.0) THEN
27169
27170         DO I=1,3
27171           if(I.EQ.3) then
27172             ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27173           else
27174             ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27175           endif
27176           ALQCD2(I,1) = PARMDL(148)
27177      &                 *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27178           ALQCD2(I,3) = PARMDL(149)
27179      &                 *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27180           ALQCD2(I,4) = PARMDL(150)
27181      &                 *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27182
27183         ENDDO
27184
27185       ELSE IF(IMODE.LT.0) THEN
27186
27187         if(IMODE.eq.-4) then
27188           I = 3
27189           ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27190         else
27191           I = -IMODE
27192           ALQCD2(I,2) = Q2
27193         endif
27194         ALQCD2(I,1) = PARMDL(148)
27195      &               *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27196         ALQCD2(I,3) = PARMDL(149)
27197      &               *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27198         ALQCD2(I,4) = PARMDL(150)
27199      &               *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27200
27201       ENDIF
27202
27203       END
27204
27205 CDECK  ID>, PHO_DFWRAP
27206       SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27207 C**********************************************************************
27208 C
27209 C     wrapper for diffraction dissociation in hadron-nucleus and
27210 C     nucleus-nucleus collisions with DPMJET
27211 C
27212 C     input:      MODE     1:   transformation into CMS
27213 C                          2:   transformation into Lab
27214 C                 JM1/2    indices of old mother particles
27215 C                 JM1/2N   indices of new mother particles
27216 C
27217 C**********************************************************************
27218
27219       IMPLICIT NONE
27220
27221       SAVE
27222
27223       INTEGER MODE,JM1,JM2
27224
27225 C  input/output channels
27226       INTEGER LI,LO
27227       COMMON /POINOU/ LI,LO
27228 C  event debugging information
27229       INTEGER NMAXD
27230       PARAMETER (NMAXD=100)
27231       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27232      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27233       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27234      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27235
27236 C  standard particle data interface
27237       INTEGER NMXHEP
27238
27239       PARAMETER (NMXHEP=4000)
27240
27241       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27242       DOUBLE PRECISION PHEP,VHEP
27243       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27244      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27245      &                VHEP(4,NMXHEP)
27246 C  extension to standard particle data interface (PHOJET specific)
27247       INTEGER IMPART,IPHIST,ICOLOR
27248       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27249
27250 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
27251       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27252       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27253       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27254      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27255
27256       DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27257       DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27258
27259       INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27260
27261 C  transformation into CMS
27262
27263       IF(MODE.EQ.1) THEN
27264
27265         JM1S = JM1
27266         JM2S = JM2
27267         NHEPS = NHEP
27268
27269         XM1 = PHEP(5,JM1)
27270         XM2 = PHEP(5,JM2)
27271
27272 C  boost into CMS
27273         P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27274         P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27275         P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27276         P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27277         SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27278         ECMD = SQRT(SS)
27279         DO 10 I=1,4
27280           GAMBED(I) = P1(I)/ECMD
27281  10     CONTINUE
27282         CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27283      &             PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27284      &             PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27285 C  rotation angles
27286         CODD = P1(3)/PTOT1
27287         SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27288         COFD = 1.D0
27289         SIFD = 0.D0
27290         IF(PTOT1*SIDD.GT.1.D-5) THEN
27291           COFD = P1(1)/(SIDD*PTOT1)
27292           SIFD = P1(2)/(SIDD*PTOT1)
27293           ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27294           COFD = COFD/ANORF
27295           SIFD = SIFD/ANORF
27296         ENDIF
27297
27298 C  initial particles in CMS
27299
27300         P1(1) = 0.D0
27301         P1(2) = 0.D0
27302         P1(3) = ECMD/2.D0*XPSUB
27303         P1(4) = P1(3)
27304
27305         P2(1) = 0.D0
27306         P2(2) = 0.D0
27307         P2(3) = -ECMD/2.D0*XTSUB
27308         P2(4) = -P2(3)
27309
27310         CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27311
27312         CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27313      &    P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27314      &    ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27315
27316         CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27317      &    P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27318      &    ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27319
27320         JM1 = JM1N
27321         JM2 = JM2N
27322
27323 C  transformation into lab.
27324
27325       ELSE IF(MODE.EQ.2) THEN
27326
27327         CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27328      &    GAMBED(1),GAMBED(2),GAMBED(3))
27329
27330         JM1 = JM1S
27331         JM2 = JM2S
27332
27333 C  clean up after rejection
27334
27335       ELSE IF(MODE.EQ.-2) THEN
27336
27337         NHEP = NHEPS
27338
27339         JM1 = JM1S
27340         JM2 = JM2S
27341
27342       ELSE
27343
27344         WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27345
27346       ENDIF
27347
27348       END
27349
27350 CDECK  ID>, PHO_DIFDIS
27351       SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27352      &                      MSOFT,MHARD,IREJ)
27353 C***********************************************************************
27354 C
27355 C     sampling of diffractive events of different kinds,
27356 C                            (produced particles stored in /POEVT1/)
27357 C
27358 C     input:   IDIF1/2   diffractive process particle 1/2
27359 C                          0   elastic/quasi-elastic scattering
27360 C                          1   diffraction dissociation
27361 C              IMOTH1/2  index of mother particles in /POEVT1/
27362 C              SPROB     suppression factor (survival probability) for
27363 C                        resolved diffraction dissociation
27364 C              IMODE     mode of operation
27365 C                          0  sampling of diffractive cut
27366 C                          1  sampling of enhanced cut
27367 C                          2  sampling of diffractive cut without
27368 C                             scattering (needed for double-pomeron)
27369 C                         -1  initialization
27370 C                         -2  output of statistics
27371 C
27372 C     output:   MSOFT    number of generated soft strings
27373 C               MHARD    number of generated hard strings
27374 C               IDIF1/2  diffraction label for particle 1/2 in /PROCES/
27375 C                          0   quasi elastic scattering
27376 C                          1   low-mass diffractive dissociation
27377 C                          2   soft high-mass diffractive dissociation
27378 C                          3   hard resolved diffractive dissociation
27379 C                          4   hard direct diffractive dissociation
27380 C               IREJ     rejection label
27381 C                          0  successful generation of partons
27382 C                          1  failure
27383 C
27384 C***********************************************************************
27385       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27386       SAVE
27387
27388       PARAMETER ( EPS  = 1.D-7,
27389      &            DEPS = 1.D-10)
27390
27391 C  input/output channels
27392       INTEGER LI,LO
27393       COMMON /POINOU/ LI,LO
27394 C  event debugging information
27395       INTEGER NMAXD
27396       PARAMETER (NMAXD=100)
27397       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27398      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27399       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27400      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27401 C  general process information
27402       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27403       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27404 C  internal rejection counters
27405       INTEGER NMXJ
27406       PARAMETER (NMXJ=60)
27407       CHARACTER*10 REJTIT
27408       INTEGER IFAIL
27409       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27410 C  global event kinematics and particle IDs
27411       INTEGER IFPAP,IFPAB
27412       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27413       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27414 C  c.m. kinematics of diffraction
27415       INTEGER NPOSD
27416       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27417      &                 SIDD,CODD,SIFD,COFD,PDCMS
27418       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27419      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27420 C  obsolete cut-off information
27421       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27422       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27423 C  some constants
27424       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27425       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27426      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27427 C  model switches and parameters
27428       CHARACTER*8 MDLNA
27429       INTEGER ISWMDL,IPAMDL
27430       DOUBLE PRECISION PARMDL
27431       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27432 C  Reggeon phenomenology parameters
27433       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27434      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27435       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27436      &                ALREG,ALREGP,GR(2),B0REG(2),
27437      &                GPPP,GPPR,B0PPP,B0PPR,
27438      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27439 C  parameters of 2x2 channel model
27440       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27441       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27442 C  table of particle indices for recursive PHOJET calls
27443       INTEGER MAXIPX
27444       PARAMETER ( MAXIPX = 100 )
27445       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27446       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27447      &                IPOIX1,IPOIX2,IPOIX3
27448
27449 C  standard particle data interface
27450       INTEGER NMXHEP
27451
27452       PARAMETER (NMXHEP=4000)
27453
27454       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27455       DOUBLE PRECISION PHEP,VHEP
27456       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27457      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27458      &                VHEP(4,NMXHEP)
27459 C  extension to standard particle data interface (PHOJET specific)
27460       INTEGER IMPART,IPHIST,ICOLOR
27461       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27462
27463 C  event weights and generated cross section
27464       INTEGER IPOWGC,ISWCUT,IVWGHT
27465       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27466       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27467      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27468
27469       DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27470       DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27471       DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27472      &          IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27473      &          IDIR(2),IPROC(2)
27474
27475       IF(IMODE.EQ.-1) THEN
27476 C  initialization
27477         RETURN
27478       ELSE IF(IMODE.EQ.-2) THEN
27479 C  output of statistics
27480         RETURN
27481       ENDIF
27482
27483       IREJ = 0
27484 C  mass cuts
27485       PIMASS  = 0.140D0
27486 C  debug output
27487       IF(IDEB(45).GE.10) THEN
27488         WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27489      &    'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27490      &    IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27491       ENDIF
27492       IPAR(1) = IDIF1
27493       IPAR(2) = IDIF2
27494 C  save current status
27495       MSOFT = 0
27496       MHARD = 0
27497       KHPOMS = KHPOM
27498       KSPOMS = KSPOM
27499       KSREGS = KSREG
27500       KHDIRS = KHDIR
27501       IPOIS1 = IPOIX1
27502       IPOIS2 = IPOIX2
27503       IPOIS3 = IPOIX3
27504       JDA11 = JDAHEP(1,IMOTH1)
27505       JDA21 = JDAHEP(2,IMOTH1)
27506       JDA12 = JDAHEP(1,IMOTH2)
27507       JDA22 = JDAHEP(2,IMOTH2)
27508       ISTH1 = ISTHEP(IMOTH1)
27509       ISTH2 = ISTHEP(IMOTH2)
27510       NHEPS = NHEP
27511 C  get mother data
27512       NPOSD(1) = IMOTH1
27513       NPOSD(2) = IMOTH2
27514       DO 20 I=1,2
27515         IDPDG(I) = IDHEP(NPOSD(I))
27516         IDBAM(I) = IMPART(NPOSD(I))
27517         AMP(I) = PHO_PMASS(IDBAM(I),0)
27518         IF(IDPDG(I).EQ.22) THEN
27519           PMASSD(I) = 0.765D0
27520           PVIRTD(I) = PHEP(5,NPOSD(I))**2
27521         ELSE
27522           PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27523           PVIRTD(I) = 0.D0
27524         ENDIF
27525  20   CONTINUE
27526 C  get CM system
27527       P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27528       P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27529       P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27530       P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27531       SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27532       ECMD = SQRT(SS)
27533       IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27534      &  'PHO_DIFDIS: availabe energy',ECMD
27535 C  check total available energy
27536       IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27537         IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27538      &    'PHO_DIFDIS: ',
27539      &    'not enough energy for inelastic diffraction',
27540      &    'ECM, particle masses:',ECMD,AMP
27541         IFAIL(7) = IFAIL(7)+1
27542         IREJ = 1
27543         RETURN
27544       ENDIF
27545 C  boost into CMS
27546       DO 10 I=1,4
27547         GAMBED(I) = P1(I)/ECMD
27548  10   CONTINUE
27549       CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27550      &           PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27551      &           PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27552 C  rotation angles
27553       CODD = P1(3)/PTOT1
27554       SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27555       COFD = 1.D0
27556       SIFD = 0.D0
27557       IF(PTOT1*SIDD.GT.1.D-5) THEN
27558         COFD = P1(1)/(SIDD*PTOT1)
27559         SIFD = P1(2)/(SIDD*PTOT1)
27560         ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27561         COFD = COFD/ANORF
27562         SIFD = SIFD/ANORF
27563       ENDIF
27564 C  initial particles in CMS
27565       PDCMS(1,1) = 0.D0
27566       PDCMS(2,1) = 0.D0
27567       PDCMS(3,1) = PTOT1
27568       PDCMS(4,1) = P1(4)
27569       PDCMS(1,2) = 0.D0
27570       PDCMS(2,2) = 0.D0
27571       PDCMS(3,2) = -PTOT1
27572       PDCMS(4,2) = ECMD-P1(4)
27573 C  get new CM momentum
27574       AM12 = PMASSD(1)**2
27575       AM22 = PMASSD(2)**2
27576       PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27577
27578 C  coherence constraint (min/max diffractive mass allowed)
27579       IF(IMODE.EQ.2) THEN
27580         THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27581         THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27582         THRM2 = SQRT(1-PARMDL(72))*ECMD
27583         THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27584       ELSE
27585         THRM1 = PARMDL(46)
27586         THRM2 = PARMDL(45)*ECMD
27587 C  check kinematic limits
27588         IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27589         IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27590       ENDIF
27591
27592 C  check energy vs. coherence constraints
27593       IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27594       IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27595
27596 C  no phase space available
27597       IF(IPAR(1)+IPAR(2).EQ.0) THEN
27598         IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27599      &    'PHO_DIFDIS: ',
27600      &    'not enough phase space for ine. diffraction (Ecm)',ECMD,
27601      &    'side 1: min. mass, upper mass limit:',
27602      &    MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27603      &    'side 2: min. mass, upper mass limit:',
27604      &    MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27605         IFAIL(7) = IFAIL(7)+1
27606         IREJ = 1
27607         RETURN
27608       ENDIF
27609
27610       ITRY = 0
27611       ITRYM = 10
27612       IPARS1 = IPAR(1)
27613       IPARS2 = IPAR(2)
27614
27615 C  main rejection loop
27616 C -------------------------------
27617  50   CONTINUE
27618       ITRY = ITRY+1
27619       IF(ITRY.GT.1) THEN
27620         IFAIL(13) = IFAIL(13)+1
27621         IF(ITRY.GE.ITRYM) THEN
27622           IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27623      &      'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27624           IFAIL(7) = IFAIL(7)+1
27625           IREJ = 1
27626           RETURN
27627         ENDIF
27628       ENDIF
27629       KSPOM = KSPOMS
27630       KHPOM = KHPOMS
27631       KHDIR = KHDIRS
27632       KSREG = KSREGS
27633       IPAR(1) = IPARS1
27634       IPAR(2) = IPARS2
27635 C  reset mother-daugther relations
27636       NHEP = NHEPS
27637       JDAHEP(1,IMOTH1) = JDA11
27638       JDAHEP(2,IMOTH1) = JDA21
27639       JDAHEP(1,IMOTH2) = JDA12
27640       JDAHEP(2,IMOTH2) = JDA22
27641       ISTHEP(IMOTH1) = ISTH1
27642       ISTHEP(IMOTH2) = ISTH2
27643       IPOIX1 = IPOIS1
27644       IPOIX2 = IPOIS2
27645       IPOIX3 = IPOIS3
27646 C
27647       NSLP = 0
27648       NCOR = 0
27649  55   CONTINUE
27650
27651 C  calculation of kinematics
27652       DO 100 I=1,2
27653 C  sampling of masses
27654         IRPDG(I) = 0
27655         IRBAM(I) = 0
27656         IFL1P(I) = IDPDG(I)
27657         IFL2P(I) = IDBAM(I)
27658         IVEC(I)  = 0
27659         IDIR(I) = 0
27660         ISAM(I) = 0
27661         JSAM(I) = 0
27662         KSAM(I) = 0
27663         IF(IPAR(I).EQ.0) THEN
27664 C  vector meson dominance assumed
27665           XMASS(I) = AMP(I)
27666           CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27667 C  diffraction dissociation
27668         ELSE IF(IPAR(I).EQ.1) THEN
27669           XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27670           PREF2 = PMASSD(I)**2
27671           XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27672         ELSE
27673           WRITE(LO,'(/1X,A,2I3)')
27674      &      'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27675           CALL PHO_ABORT
27676         ENDIF
27677  100  CONTINUE
27678
27679 C  sampling of momentum transfer
27680       CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27681      &            THRM2,TT,SLWGHT,IREJ)
27682       IF(IREJ.NE.0) THEN
27683         NSLP=NSLP+1
27684         IF(NSLP.LT.100) GOTO 55
27685         WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27686      &   'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27687         IREJ = 5
27688         RETURN
27689       ENDIF
27690
27691 C  correct for t-M^2 correlation in diffraction
27692       IF(DT_RNDM(TT).GT.SLWGHT) THEN
27693         NCOR=NCOR+1
27694         IF(NCOR.LT.100) GOTO 55
27695         WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27696      &   'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27697         IREJ = 5
27698         RETURN
27699       ENDIF
27700
27701 C  debug output
27702       IF(IDEB(45).GE.5) THEN
27703         WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27704      &    'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27705       ENDIF
27706 C  not double pomeron scattering
27707       IF(IMODE.NE.2) THEN
27708 C  sample diffractive interaction processes
27709         DO 120 I=1,2
27710           IF(IPAR(I).NE.0) THEN
27711 C  find particle combination
27712             IF(IDPDG(I).EQ.IFPAP(1)) THEN
27713               IP = 2
27714             ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27715               IP = 3
27716             ELSE IF(IDPDG(I).EQ.990) THEN
27717               IP = 4
27718             ELSE
27719               IP = I+1
27720             ENDIF
27721 C  sample dissociation process
27722             CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27723      &        PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27724      &        KSAM(I),IDIR(I))
27725             IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27726 C  store process label
27727               IF(IDIR(I).GT.0) THEN
27728                 IPAR(I) = 4
27729               ELSE IF(KSAM(I).GT.0) THEN
27730                 IPAR(I) = 3
27731               ELSE IF(ISAM(I).GT.0) THEN
27732                 IPAR(I) = 2
27733               ELSE
27734                 IPAR(I) = 1
27735 C  mass fine correction
27736                 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27737      &            XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27738                 XMASS(I) = XMNEW
27739               ENDIF
27740             ELSE
27741 C  diffractive pomeron-hadron interaction
27742               IPAR(I) = 10+IPROC(I)
27743             ENDIF
27744 C  debug output
27745             IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27746      &        'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27747      &        IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27748           ENDIF
27749  120    CONTINUE
27750       ENDIF
27751 C  actualize debug information
27752       IF(IMODE.EQ.1) THEN
27753         IDIFR1 = IPAR(1)
27754         IDIFR2 = IPAR(2)
27755       ENDIF
27756 C  calculate new momenta in CMS
27757       CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27758       IF(IREJ.NE.0) GOTO 50
27759       DO 130 I=1,4
27760         PP(I,1) = P1(I)
27761         PP(I,2) = P2(I)
27762  130  CONTINUE
27763
27764 C  comment line for diffraction
27765       CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27766      &   XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27767 C  write diffractive strings/particles
27768       DO 200 I=1,2
27769         I1 = I
27770         I2 = 3-I1
27771         DO K=1,4
27772           PD1(K) = PP(K,I1)
27773           PD2(K) = PP(K,I2)
27774         ENDDO
27775         PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27776         PP(7,I1) = TT
27777         IGEN = IPHIST(2,NPOSD(I1))
27778         if(IGEN.eq.0) IGEN = -I1*10
27779         CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27780      &    IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27781         IF(IREJ.NE.0) THEN
27782           IFAIL(7+I) = IFAIL(7+I)+1
27783           IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27784      &      'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27785      &      I,IPAR(I),XMASS(I)
27786           GOTO 50
27787         ENDIF
27788         ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27789  200  CONTINUE
27790 C  double-pomeron scattering?
27791       IF(IMODE.EQ.2) GOTO 150
27792
27793 C  diffractive final states
27794       DO 300 I=1,2
27795  110    CONTINUE
27796         IF(IPAR(I).EQ.0) THEN
27797 C  vector meson production
27798           IF(IDPDG(I).EQ.22) THEN
27799             IF(ISWMDL(21).GE.0) THEN
27800               ISP = IPAMDL(3)
27801               IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27802               CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27803             ENDIF
27804 C  hadronic state of multi-pomeron coupling
27805           ELSE IF(IDPDG(I).EQ.990) THEN
27806             CALL PHO_SDECAY(IPOSP(1,I),0,2)
27807           ENDIF
27808         ELSE
27809           IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27810             IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
27811             IF(IDIR(I).GT.0) THEN
27812               IPAR(I) = 4
27813             ELSE IF(KSAM(I).GT.0) THEN
27814               IPAR(I) = 3
27815             ELSE IF(ISAM(I).GT.0) THEN
27816               IPAR(I) = 2
27817             ELSE
27818               IPAR(I) = 1
27819             ENDIF
27820           ELSE
27821             IPAR(I) = 10+IPROC(I)
27822           ENDIF
27823           IPHIST(I,ICPOS) = IPAR(I)
27824 C  update debug informantion
27825           KSPOM = ISAM(I)
27826           KSREG = JSAM(I)
27827           KHPOM = KSAM(I)
27828           KHDIR = IDIR(I)
27829           IDIFR1 = IPAR(1)
27830           IDIFR2 = IPAR(2)
27831           IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
27832
27833 C  resonance decay, pi+pi- background
27834             P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
27835             P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
27836             P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
27837             P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
27838             CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
27839      &        P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
27840 C  decay
27841             IF(IDPDG(I).EQ.22) THEN
27842               IPHIST(2,IPOS) = 3
27843               IF(ISWMDL(21).GE.0) THEN
27844                 ISP = IPAMDL(3)
27845                 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
27846                 CALL PHO_SDECAY(IPOS,ISP,2)
27847               ENDIF
27848             ELSE
27849               CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
27850             ENDIF
27851             IREJ = 0
27852           ELSE
27853
27854 C  particle-pomeron scattering
27855             IF(IPAR(I).LE.4) THEN
27856 C  non-diffractive particle-pomeron scattering
27857               IGEN = IPHIST(2,NPOSD(I))
27858               if(IGEN.eq.0) then
27859                 if(I.eq.1) then
27860                   IGEN = 5
27861                 else
27862                   IGEN = 6
27863                 endif
27864               endif
27865               CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
27866      &          ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
27867             ELSE
27868 C  diffractive particle-pomeron scattering
27869               IPOIX2 = IPOIX2+1
27870               IPORES(IPOIX2)   = IPROC(I)
27871               IPOPOS(1,IPOIX2) = IPOSP(1,I)
27872               IPOPOS(2,IPOIX2) = IPOSP(2,I)
27873             ENDIF
27874           ENDIF
27875         ENDIF
27876
27877 C  rejection?
27878         IF(IREJ.NE.0) THEN
27879           IFAIL(20+I) = IFAIL(20+I)+1
27880           IF(IPAR(I).GT.1) THEN
27881             IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
27882             IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
27883             IF(IDIR(I).GT.0) THEN
27884               IDIR(I) = 0
27885             ELSE IF(KSAM(I).GT.0) THEN
27886               KSAM(I) = KSAM(I)-1
27887             ELSE IF(ISAM(I).GT.0) THEN
27888               ISAM(I) = ISAM(I)-1
27889             ENDIF
27890             GOTO 110
27891           ELSE
27892             IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
27893      &        'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
27894      &        I,IPAR(I),XMASS(I)
27895             GOTO 50
27896           ENDIF
27897         ENDIF
27898  300  CONTINUE
27899
27900       IDIF1 = IPAR(1)
27901       IDIF2 = IPAR(2)
27902 C  update debug information
27903       KSPOM = KSPOMS+ISAM(1)+ISAM(2)
27904       KSREG = KSREGS+JSAM(1)+JSAM(2)
27905       KHPOM = KHPOMS+KSAM(1)+KSAM(2)
27906       KHDIR = KHDIRS+IDIR(1)+IDIR(2)
27907
27908  150  CONTINUE
27909
27910 C  debug output
27911       IF(IDEB(45).GE.10) THEN
27912         WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
27913      &    'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27914      &    IPAR,NPOSD,MSOFT,MHARD,IMODE
27915       ENDIF
27916       IF(IDEB(45).GE.15) THEN
27917         WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
27918      &                        '------------------------------'
27919         CALL PHO_PREVNT(0)
27920       ENDIF
27921
27922       END
27923
27924 CDECK  ID>, PHO_DIFPRO
27925       SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
27926      &                  IPROC,ISAM,JSAM,KSAM,IDIR)
27927 C*********************************************************************
27928 C
27929 C     sampling of diffraction dissociation process
27930 C
27931 C     input:  IP       particle combination
27932 C             ICUT     user imposed limitations
27933 C             ID1/2    PDG particle code of scattering particles
27934 C             XMASS    diffractively produced mass (GeV)
27935 C             P2V1/2   virtuality of scattering particles (Gev**2)
27936 C             SPROB    suppression factor for resolved single and
27937 C                      double diffraction dissociation
27938 C
27939 C     output: IRPOC    process ID
27940 C             ISAM     number of cut pomerons (soft)
27941 C             JSAM     number of cut reggeons
27942 C             KSAM     number of cut pomerons (hard)
27943 C             IDIR     direct hard interaction
27944 C
27945 C*********************************************************************
27946       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27947       SAVE
27948
27949 C  input/output channels
27950       INTEGER LI,LO
27951       COMMON /POINOU/ LI,LO
27952 C  event debugging information
27953       INTEGER NMAXD
27954       PARAMETER (NMAXD=100)
27955       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27956      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27957       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27958      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27959 C  general process information
27960       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27961       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27962 C  model switches and parameters
27963       CHARACTER*8 MDLNA
27964       INTEGER ISWMDL,IPAMDL
27965       DOUBLE PRECISION PARMDL
27966       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27967 C  energy-interpolation table
27968       INTEGER IEETA2
27969       PARAMETER ( IEETA2 = 20 )
27970       INTEGER ISIMAX
27971       DOUBLE PRECISION SIGTAB,SIGECM
27972       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
27973
27974       ISAM = 0
27975       JSAM = 0
27976       KSAM = 0
27977       IDIR = 0
27978
27979       IF(XMASS.GT.3.D0) THEN
27980 C  rapidity gap survival probability
27981         SPRO = 1.D0
27982         IF(ISWMDL(28).GE.1) SPRO = SPROB
27983 C  sample interaction
27984         IPROC = 0
27985         CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
27986       ELSE
27987         IPROC = 1
27988       ENDIF
27989       IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
27990 C  non-diffractive hadron-pomeron interaction
27991       IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
27992 C  option for suppression of multiple interaction
27993         IF(ICUT.EQ.0) THEN
27994           IPROC = 1
27995           IF(ISAM+KSAM+IDIR.GT.0) THEN
27996             ISAM = 1
27997             JSAM = 0
27998           ELSE
27999             JSAM = 1
28000           ENDIF
28001           KSAM = 0
28002           IDIR = 0
28003         ELSE IF(ICUT.EQ.1) THEN
28004           IF(IDIR.GT.0) THEN
28005           ELSE IF(KSAM.GT.0) THEN
28006             KSAM = 1
28007             ISAM = 0
28008             JSAM = 0
28009           ELSE IF(ISAM.GT.0) THEN
28010             ISAM = 1
28011             JSAM = 0
28012           ELSE
28013             JSAM = 1
28014           ENDIF
28015         ELSE IF(ICUT.EQ.2) THEN
28016           KSAM = MIN(KSAM,1)
28017         ELSE IF(ICUT.EQ.3) THEN
28018           ISAM = MIN(ISAM,1)
28019         ENDIF
28020       ENDIF
28021       END
28022
28023 CDECK  ID>, PHO_DIFPAR
28024       SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
28025      &                     IPOSH1,IPOSH2,IMODE,IREJ)
28026 C***********************************************************************
28027 C
28028 C     perform string construction for diffraction dissociation
28029 C
28030 C     input:     IMOTH1,2     index of mother particles in POEVT1
28031 C                IGENM        production process of mother particles
28032 C                IFL1,IFL2    particle numbers
28033 C                             (IDPDG,IDBAM for quasi-elas. hadron)
28034 C                IPAR         0  quasi-elasic scattering
28035 C                             1  single string configuration
28036 C                             2  two string configuration
28037 C                P1           massive 4 momentum of first
28038 C                P1(6)        virtuality/squ.mass of particle (GeV**2)
28039 C                P1(7)        virtuality of Pomeron (neg, GeV**2)
28040 C                P2           massive 4 momentum of second particle
28041 C                IMODE        1   diffraction dissociation
28042 C                             2   double-pomeron scattering
28043 C
28044 C     output:    IPOSH1,2     index of the particles in /POEVT1/
28045 C                IREJ         0  successful string construction
28046 C                             1  no string construction possible
28047 C
28048 C***********************************************************************
28049       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28050       SAVE
28051
28052       DIMENSION P1(7),P2(7)
28053
28054       PARAMETER ( EPS  = 1.D-7,
28055      &            DEPS = 1.D-10)
28056
28057 C  input/output channels
28058       INTEGER LI,LO
28059       COMMON /POINOU/ LI,LO
28060 C  event debugging information
28061       INTEGER NMAXD
28062       PARAMETER (NMAXD=100)
28063       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28064      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28065       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28066      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28067 C  internal rejection counters
28068       INTEGER NMXJ
28069       PARAMETER (NMXJ=60)
28070       CHARACTER*10 REJTIT
28071       INTEGER IFAIL
28072       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28073 C  c.m. kinematics of diffraction
28074       INTEGER NPOSD
28075       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28076      &                 SIDD,CODD,SIFD,COFD,PDCMS
28077       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28078      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28079 C  model switches and parameters
28080       CHARACTER*8 MDLNA
28081       INTEGER ISWMDL,IPAMDL
28082       DOUBLE PRECISION PARMDL
28083       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28084 C  some constants
28085       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28086       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28087      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28088
28089 C  standard particle data interface
28090       INTEGER NMXHEP
28091
28092       PARAMETER (NMXHEP=4000)
28093
28094       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28095       DOUBLE PRECISION PHEP,VHEP
28096       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28097      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28098      &                VHEP(4,NMXHEP)
28099 C  extension to standard particle data interface (PHOJET specific)
28100       INTEGER IMPART,IPHIST,ICOLOR
28101       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28102
28103       DIMENSION PCH1(2,4)
28104       data IC1 /0/
28105       data IC2 /0/
28106
28107       IREJ = 0
28108       ILTR1 = NHEP+1
28109       IGEN = IGENM
28110       if(IGENM.le.-10) IGEN = 0
28111
28112 C  elastic part
28113       IF(IPAR.EQ.0) THEN
28114         IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28115           if(IGEN.eq.0) IGEN = 3
28116 C  pi+/pi- isotropic background
28117           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28118      &      P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28119           CALL PHO_SDECAY(IPOSH1,0,-2)
28120         ELSE
28121           if(IGEN.eq.0) then
28122             IGEN = 2
28123             if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28124           endif
28125 C  registration of particle or resonance
28126           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28127      &      P1(4),0,IGEN,0,0,IPOSH1,1)
28128         ENDIF
28129
28130 C  diffraction dissociation
28131       ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28132 C  calculation of resulting particle momenta
28133         IF(IMOTH1.EQ.NPOSD(1)) THEN
28134           K = 2
28135         ELSE
28136           K = 1
28137         ENDIF
28138         DO 100 I=1,4
28139           PCH1(2,I) = PDCMS(I,K)-P2(I)
28140           PCH1(1,I) = P1(I)-PCH1(2,I)
28141  100    CONTINUE
28142
28143 C  registration
28144         if(IMODE.LT.2) then
28145           if(IGEN.eq.0) IGEN = -IGENM/10+4
28146           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28147      &      PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28148         else
28149           if(IGEN.eq.0) IGEN = 4
28150         endif
28151         CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28152      &    PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28153
28154 C  invalid IPAR
28155       ELSE
28156         WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28157         CALL PHO_ABORT
28158       ENDIF
28159
28160 C  back transformation
28161       CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28162      &  GAMBED(1),GAMBED(2),GAMBED(3))
28163
28164       END
28165
28166 CDECK  ID>, PHO_QELAST
28167       SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28168 C**********************************************************************
28169 C
28170 C     sampling of quasi elastic processes
28171 C
28172 C     input:   IPROC  2   purely elastic scattering
28173 C              IPROC  3   q-ela. omega/omega/phi/pi+pi- production
28174 C              IPROC  4   double pomeron scattering
28175 C              IPROC  -1  initialization
28176 C              IPROC  -2  output of statistics
28177 C              JM1/2      index of initial particle 1/2
28178 C
28179 C     output:  initial and final particles in /POEVT1/ involving
28180 C              polarized resonances in /POEVT1/ and decay
28181 C              products
28182 C
28183 C              IREJ    0  successful
28184 C                      1  failure
28185 C                     50  user rejection
28186 C
28187 C**********************************************************************
28188       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28189       SAVE
28190
28191       PARAMETER ( NTAB = 20,
28192      &            EPS  = 1.D-10,
28193      &            PIMASS = 0.13D0,
28194      &            DEPS = 1.D-10)
28195
28196 C  input/output channels
28197       INTEGER LI,LO
28198       COMMON /POINOU/ LI,LO
28199 C  event debugging information
28200       INTEGER NMAXD
28201       PARAMETER (NMAXD=100)
28202       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28203      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28204       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28205      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28206 C  global event kinematics and particle IDs
28207       INTEGER IFPAP,IFPAB
28208       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28209       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28210 C  c.m. kinematics of diffraction
28211       INTEGER NPOSD
28212       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28213      &                 SIDD,CODD,SIFD,COFD,PDCMS
28214       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28215      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28216 C  model switches and parameters
28217       CHARACTER*8 MDLNA
28218       INTEGER ISWMDL,IPAMDL
28219       DOUBLE PRECISION PARMDL
28220       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28221 C  some constants
28222       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28223       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28224      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28225 C  cross sections
28226       INTEGER IPFIL,IFAFIL,IFBFIL
28227       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28228      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28229      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28230      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28231      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28232       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28233      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28234      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28235      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28236      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28237      &                IPFIL,IFAFIL,IFBFIL
28238
28239 C  standard particle data interface
28240       INTEGER NMXHEP
28241
28242       PARAMETER (NMXHEP=4000)
28243
28244       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28245       DOUBLE PRECISION PHEP,VHEP
28246       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28247      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28248      &                VHEP(4,NMXHEP)
28249 C  extension to standard particle data interface (PHOJET specific)
28250       INTEGER IMPART,IPHIST,ICOLOR
28251       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28252
28253       DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28254       DIMENSION   P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28255       DIMENSION   IFL(2),IDPRO(4)
28256       character*15 pho_pname
28257       CHARACTER*8  VMESA(0:4),VMESB(0:4)
28258       DIMENSION   ISAMVM(4,4)
28259       DATA IDPRO / 113,223,333,92 /
28260       DATA VMESA / 'vmeson  ','rho     ','omega   ','phi     ',
28261      &             'pi+pi-  ' /
28262       DATA VMESB / 'vmeson  ','rho     ','omega   ','phi     ',
28263      &             'pi+pi-  ' /
28264
28265 C  sampling of elastic/quasi-elastic processes
28266       IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28267         IREJ = 0
28268         NPOSD(1) = JM1
28269         NPOSD(2) = JM2
28270         DO 55 I=1,2
28271           PMI(I) = PHEP(5,NPOSD(I))
28272           IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28273  55     CONTINUE
28274 C  get CM system
28275         PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28276         PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28277         PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28278         PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28279         SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28280         ECMD = SQRT(SS)
28281
28282         IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28283           IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28284      &      'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28285      &      ECMD,PMI
28286           IREJ = 5
28287           RETURN
28288         ENDIF
28289
28290         DO 60 I=1,4
28291           GAMBED(I) = PK1(I)/ECMD
28292  60     CONTINUE
28293         CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28294      &           PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28295      &           PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28296 C  rotation angles
28297         CODD = PK1(3)/PTOT1
28298         SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28299         COFD = 1.D0
28300         SIFD = 0.D0
28301         IF(PTOT1*SIDD.GT.1.D-5) THEN
28302           COFD = PK1(1)/(SIDD*PTOT1)
28303           SIFD = PK1(2)/(SIDD*PTOT1)
28304           ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28305           COFD = COFD/ANORF
28306           SIFD = SIFD/ANORF
28307         ENDIF
28308 C  get CM momentum
28309         AM12 = PMI(1)**2
28310         AM22 = PMI(2)**2
28311         PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28312
28313 C  production process of mother particles
28314         IGEN = IPHIST(2,NPOSD(1))
28315         if(IGEN.eq.0) IGEN = IPROC
28316
28317         ICALL = ICALL + 1
28318 C  main rejection label
28319  50     CONTINUE
28320 C  determine process and final particles
28321         IFL(1) = IDHEP(NPOSD(1))
28322         IFL(2) = IDHEP(NPOSD(2))
28323         IF(IPROC.EQ.3) THEN
28324           ITRY = 0
28325  100      CONTINUE
28326           ITRY = ITRY+1
28327           IF(ITRY.GT.50) THEN
28328             IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28329      &        'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28330      &        ITRY,ECMD
28331             IREJ = 5
28332             RETURN
28333           ENDIF
28334           XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28335           DO 110 I=1,4
28336             DO 120 J=1,4
28337               XI = XI-SIGVM(I,J)
28338               IF(XI.LE.0.D0) GOTO 130
28339  120        CONTINUE
28340  110      CONTINUE
28341  130      CONTINUE
28342           IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28343           IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28344           ISAMVM(I,J) = ISAMVM(I,J)+1
28345           ISAMQE = ISAMQE+1
28346 C  sample new masses
28347           CALL PHO_SAMASS(IFL(1),RMASS(1))
28348           CALL PHO_SAMASS(IFL(2),RMASS(2))
28349           IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28350         ELSE IF(IPROC.EQ.2) THEN
28351           I = 0
28352           J = 0
28353           ISAMEL = ISAMEL+1
28354           RMASS(1) = PHO_PMASS(NPOSD(1),2)
28355           RMASS(2) = PHO_PMASS(NPOSD(2),2)
28356         ELSE
28357           WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28358           CALL PHO_ABORT
28359         ENDIF
28360 C  sample momentum transfer
28361         CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28362      &    SLWGHT,IREJ)
28363         IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28364      &    'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28365 C  calculate new momenta
28366         CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28367         IF(IREJ.NE.0) GOTO 50
28368         DO K=1,4
28369           P(K,1) = PK1(K)
28370           P(K,2) = PK2(K)
28371         ENDDO
28372 C  comment line for elastic/quasi-elastic scattering
28373         CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28374      &    TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28375
28376         I1 = NHEP+1
28377 C  fill /POEVT1/
28378         DO 200 I=1,2
28379           K = 3-I
28380           IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28381 C  pi+/pi- isotropic background
28382             IGEN = 3
28383             CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28384      &        P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28385             ICOLOR(I,ICPOS) = IPOS
28386             CALL PHO_SDECAY(IPOS,0,-2)
28387           ELSE
28388 C  registration
28389             IGEN = 2
28390             if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28391             CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28392      &        P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28393             ICOLOR(I,ICPOS) = IPOS
28394           ENDIF
28395  200    CONTINUE
28396         I2 = NHEP
28397 C  search for vector mesons
28398         DO 300 I=I1,I2
28399 C  decay according to polarization
28400           IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28401             ISP = IPAMDL(3)
28402             IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28403             CALL PHO_SDECAY(I,ISP,2)
28404           ENDIF
28405  300    CONTINUE
28406         I2 = NHEP
28407 C  back transformation
28408         CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28409      &              GAMBED(2),GAMBED(3))
28410
28411 C  initialization of tables
28412       ELSE IF(IPROC.EQ.-1) THEN
28413         DO 10 I=1,4
28414           DO 20 J=1,4
28415             ISAMVM(I,J) = 0
28416  20       CONTINUE
28417  10     CONTINUE
28418         ISAMEL = 0
28419         ISAMQE = 0
28420         IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28421         IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28422         CALL PHO_SAMASS(-1,RMASS(1))
28423         ICALL = 0
28424
28425 C  output of statistics
28426       ELSE IF(IPROC.EQ.-2) THEN
28427         IF(ICALL.LT.10) RETURN
28428         WRITE(LO,'(/,1X,A,I10/,1X,A)')
28429      &    'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28430      &    '---------------------------------------------------'
28431         WRITE(LO,'(1X,A,I10)')
28432      &    'sampled elastic processes:',ISAMEL
28433         WRITE(LO,'(1X,A,I10)')
28434      &    'sampled quasi-elastic vectormeson production:',ISAMQE
28435         WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28436         DO 30 I=1,4
28437           WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28438  30     CONTINUE
28439         CALL PHO_SAMASS(-2,RMASS(1))
28440       ELSE
28441         WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28442      &    'unknown process ID',IPROC
28443         CALL PHO_ABORT
28444       ENDIF
28445
28446       END
28447
28448 CDECK  ID>, PHO_CDIFF
28449       SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28450 C**********************************************************************
28451 C
28452 C     preparation of /POEVT1/ for double-pomeron scattering
28453 C
28454 C     input:   IMOTH1/2   index of mother particles in /POEVT1/
28455 C
28456 C              IMODE   1  sampling of pomeron-pomeron scattering
28457 C                     -1  initialization
28458 C                     -2  output of statistics
28459 C
28460 C     output:   MSOFT     number of generated soft strings
28461 C               MHARD     number of generated hard strings
28462 C               IREJ      0  accepted
28463 C                         1  rejected
28464 C                        50  user rejection
28465 C
28466 C**********************************************************************
28467       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28468       SAVE
28469
28470       PARAMETER ( EPS  = 1.D-10,
28471      &            DEPS = 1.D-10)
28472
28473 C  input/output channels
28474       INTEGER LI,LO
28475       COMMON /POINOU/ LI,LO
28476 C  event debugging information
28477       INTEGER NMAXD
28478       PARAMETER (NMAXD=100)
28479       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28480      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28481       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28482      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28483 C  internal rejection counters
28484       INTEGER NMXJ
28485       PARAMETER (NMXJ=60)
28486       CHARACTER*10 REJTIT
28487       INTEGER IFAIL
28488       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28489 C  model switches and parameters
28490       CHARACTER*8 MDLNA
28491       INTEGER ISWMDL,IPAMDL
28492       DOUBLE PRECISION PARMDL
28493       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28494 C  general process information
28495       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28496       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28497 C  Reggeon phenomenology parameters
28498       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28499      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28500       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28501      &                ALREG,ALREGP,GR(2),B0REG(2),
28502      &                GPPP,GPPR,B0PPP,B0PPR,
28503      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28504 C  parameters of 2x2 channel model
28505       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28506       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28507 C  some constants
28508       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28509       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28510      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28511 C  energy-interpolation table
28512       INTEGER IEETA2
28513       PARAMETER ( IEETA2 = 20 )
28514       INTEGER ISIMAX
28515       DOUBLE PRECISION SIGTAB,SIGECM
28516       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28517 C  table of particle indices for recursive PHOJET calls
28518       INTEGER MAXIPX
28519       PARAMETER ( MAXIPX = 100 )
28520       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28521       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28522      &                IPOIX1,IPOIX2,IPOIX3
28523
28524 C  standard particle data interface
28525       INTEGER NMXHEP
28526
28527       PARAMETER (NMXHEP=4000)
28528
28529       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28530       DOUBLE PRECISION PHEP,VHEP
28531       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28532      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28533      &                VHEP(4,NMXHEP)
28534 C  extension to standard particle data interface (PHOJET specific)
28535       INTEGER IMPART,IPHIST,ICOLOR
28536       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28537
28538       DIMENSION PD(4)
28539
28540       if(IMODE.ne.1) return
28541
28542       IREJ = 0
28543       IP = 4
28544 C  select first diffraction
28545       IF(DT_RNDM(DUM).GT.0.5D0) THEN
28546         IPAR1 = 1
28547         IPAR2 = 0
28548       ELSE
28549         IPAR1 = 0
28550         IPAR2 = 1
28551       ENDIF
28552       ITRY2 = 0
28553       ITRYM = 1000
28554
28555 C  save current status
28556       MSOFT = 0
28557       MHARD = 0
28558       KHPOMS = KHPOM
28559       KSPOMS = KSPOM
28560       KSREGS = KSREG
28561       KHDIRS = KHDIR
28562       IPOIS1 = IPOIX1
28563       IPOIS2 = IPOIX2
28564       IPOIS3 = IPOIX3
28565       JDA11 = JDAHEP(1,IMOTH1)
28566       JDA21 = JDAHEP(2,IMOTH1)
28567       JDA12 = JDAHEP(1,IMOTH2)
28568       JDA22 = JDAHEP(2,IMOTH2)
28569       ISTH1 = ISTHEP(IMOTH1)
28570       ISTH2 = ISTHEP(IMOTH2)
28571       NHEPS = NHEP
28572
28573 C  find mother particle production process
28574       IGEN = IPHIST(2,IMOTH1)
28575       if(IGEN.eq.0) IGEN = 4
28576
28577 C  main generation loop
28578  60   CONTINUE
28579
28580       KSPOM = KSPOMS
28581       KHPOM = KHPOMS
28582       KHDIR = KHDIRS
28583       KSREG = KSREGS
28584       I1 = IPAR1
28585       I2 = IPAR2
28586 C  reset mother-daugther relations
28587       NHEP = NHEPS
28588       JDAHEP(1,IMOTH1) = JDA11
28589       JDAHEP(2,IMOTH1) = JDA21
28590       JDAHEP(1,IMOTH2) = JDA12
28591       JDAHEP(2,IMOTH2) = JDA22
28592       ISTHEP(IMOTH1) = ISTH1
28593       ISTHEP(IMOTH2) = ISTH2
28594       IPOIX1 = IPOIS1
28595       IPOIX2 = IPOIS2
28596       IPOIX3 = IPOIS3
28597 C  rejection counter
28598       ITRY2 = ITRY2+1
28599       IF(ITRY2.GT.1) THEN
28600         IFAIL(39) = IFAIL(39)+1
28601         IF(ITRY2.GE.ITRYM) GOTO 50
28602       ENDIF
28603 C  generate two diffractive events
28604       CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28605       IF(IREJ.NE.0) GOTO 50
28606       CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28607       IF(IREJ.NE.0) GOTO 50
28608 C  mass of pomeron-pomeron system
28609       DO 100 I2 = NHEP,1,-1
28610         IF(IDHEP(I2).EQ.990) GOTO 110
28611  100  CONTINUE
28612  110  CONTINUE
28613       DO 120 I1 = I2-1,1,-1
28614         IF(IDHEP(I1).EQ.990) GOTO 130
28615  120  CONTINUE
28616  130  CONTINUE
28617       DO 140 I=1,4
28618         PD(I) = PHEP(I,I1)+PHEP(I,I2)
28619  140  CONTINUE
28620       XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28621       IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28622      &  'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28623       IF(XMASS.LT.0.1D0) GOTO 60
28624       XMASS = SQRT(XMASS)
28625       IF(XMASS.LT.PARMDL(71)) GOTO 60
28626
28627 C  sample pomeron-pomeron interaction process
28628       CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28629      &            IPROC,ISAM,JSAM,KSAM,IDIR)
28630
28631 C  non-diffractive pomeron-pomeron interactions
28632       IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28633  200    CONTINUE
28634         IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28635 C  debug output
28636         IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28637      &    'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28638      &    IP,XMASS,ISAM,JSAM,KSAM,IDIR
28639 C  store debug information
28640         IF(IDIR.GT.0) THEN
28641           IPAR = 4
28642         ELSE IF(KSAM.GT.0) THEN
28643           IPAR = 3
28644         ELSE IF(ISAM.GT.0) THEN
28645           IPAR = 2
28646         ELSE
28647           IPAR = 1
28648         ENDIF
28649         IDDPOM = IPAR
28650         IF(ISAM+JSAM.GT.0) KSDPO = 1
28651         IF(KSAM+IDIR.GT.0) KHDPO = 1
28652         KSPOM = ISAM
28653         KSREG = JSAM
28654         KHPOM = KSAM
28655         KHDIR = IDIR
28656         KSTRG = 0
28657         KSLOO = 0
28658 C  generate pomeron-pomeron interaction
28659         CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28660         IF(IREJ.NE.0) THEN
28661           IFAIL(3) = IFAIL(3)+1
28662           IF(IPAR.GT.1) THEN
28663             IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28664             IF(IDIR.GT.0) THEN
28665               IFAIL(10) = IFAIL(10)+1
28666               IDIR = 0
28667             ELSE IF(KSAM.GT.0) THEN
28668               KSAM = KSAM-1
28669             ELSE IF(ISAM.GT.0) THEN
28670               ISAM = ISAM-1
28671             ENDIF
28672             GOTO 200
28673           ELSE
28674             IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28675      &        'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28676      &        I,IPAR,XMASS
28677             GOTO 50
28678           ENDIF
28679         ENDIF
28680
28681 C  diffractive pomeron-pomeron interactions
28682       ELSE
28683         IPOIX2 = IPOIX2+1
28684         IPORES(IPOIX2)   = IPROC
28685         IPOPOS(1,IPOIX2) = I1
28686         IPOPOS(2,IPOIX2) = I2
28687         IPAR = 10+IPROC
28688         IDDPOM = IPAR
28689       ENDIF
28690
28691 C  update debug information
28692       KSPOM = KSPOMS+ISAM
28693       KSREG = KSREGS+JSAM
28694       KHPOM = KHPOMS+KSAM
28695       KHDIR = KHDIRS+IDIR
28696 C  comment line for central diffraction
28697       CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28698      &            I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28699       PHEP(5,IPOS) = XMASS
28700 C  debug output
28701       IF(IDEB(59).GE.15) THEN
28702         WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28703      &                        '-----------------------------'
28704         CALL PHO_PREVNT(0)
28705       ENDIF
28706       RETURN
28707
28708 C  treatment of rejection
28709  50   CONTINUE
28710       IREJ = 1
28711       IFAIL(40) = IFAIL(40)+1
28712       IF(IDEB(59).GE.3) THEN
28713         WRITE(LO,'(1X,A)')
28714      &    'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28715         IF(IDEB(59).GE.10) THEN
28716           CALL PHO_PREVNT(0)
28717         ELSE
28718           CALL PHO_PREVNT(-1)
28719         ENDIF
28720       ENDIF
28721
28722       END
28723
28724 CDECK  ID>, PHO_SAMASS
28725       SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28726 C**********************************************************************
28727 C
28728 C     resonance mass sampling of quasi elastic processes
28729 C
28730 C     input:   IFLA       PDG number of particle
28731 C              IFLA   -1  initialization
28732 C              IFLA   -2  output of statistics
28733 C
28734 C     output:  RMASS      particle mass (in GeV)
28735 C
28736 C**********************************************************************
28737       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28738       SAVE
28739
28740       PARAMETER(EPS  = 1.D-10 )
28741
28742 C  input/output channels
28743       INTEGER LI,LO
28744       COMMON /POINOU/ LI,LO
28745 C  event debugging information
28746       INTEGER NMAXD
28747       PARAMETER (NMAXD=100)
28748       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28749      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28750       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28751      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28752 C  model switches and parameters
28753       CHARACTER*8 MDLNA
28754       INTEGER ISWMDL,IPAMDL
28755       DOUBLE PRECISION PARMDL
28756       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28757 C  parameters of the "simple" Vector Dominance Model
28758       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28759       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28760
28761       PARAMETER(NTABM=50)
28762       DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28763       DIMENSION SUM(4),ICALL(4)
28764
28765 C*****************************************************************
28766 C  initialization of tables
28767       IF(IFLA.EQ.-1) THEN
28768 C
28769         NSTEP = NTABM
28770         DO 102 I=1,4
28771           ICALL(I) = 0
28772
28773           DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28774           DO 105 K=1,NSTEP
28775             RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28776  105      CONTINUE
28777  102    CONTINUE
28778 C  calculate table of dsig/dm
28779         CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28780 C  output of table
28781         IF(IDEB(35).GE.1) THEN
28782           WRITE(LO,'(/5X,A)') 'table:   mass (GeV)  DSIG/DM (mub/GeV)'
28783           WRITE(LO,'(1X,A,/1X,A)')
28784      &      '  (m,  rho,     m,  omega,      m,   phi,    m,  pi+pi-)',
28785      &      ' -------------------------------------------------------'
28786           DO 106 K=1,NSTEP
28787             WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28788      &        RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28789  106      CONTINUE
28790         ENDIF
28791 C  make second table for sampling
28792         DO 109 I=1,4
28793           SUM(I) = 0.D0
28794           DO 108 K=2,NSTEP
28795             SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
28796             XMC(I,K) = SUM(I)
28797  108      CONTINUE
28798  109    CONTINUE
28799 C  normalization
28800         DO 118 K=1,NSTEP
28801           DO 119 I=1,4
28802             XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
28803  119      CONTINUE
28804  118    CONTINUE
28805         IF(IDEB(35).GE.10) THEN
28806           WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
28807           WRITE(LO,'(1X,A,/1X,A)')
28808      &      '  (m,  rho,     m,  omega,      m,   phi,    m,  pi+pi-)',
28809      &      ' -------------------------------------------------------'
28810           DO 120 K=1,NSTEP
28811             WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
28812      &        RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
28813  120      CONTINUE
28814         ENDIF
28815 C
28816 C**************************************************
28817 C  output of statistics
28818       ELSE IF(IFLA.EQ.-2) THEN
28819         WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
28820      &                        '----------------------'
28821         WRITE(LO,'(4(/8X,A,I10))') 'rho:   ',ICALL(1),
28822      &    'omega: ',ICALL(2),'phi:   ',ICALL(3),'pi+pi-:',ICALL(4)
28823
28824 C
28825 C********************************************************
28826 C  sampling of RMASS
28827       ELSE
28828 C  quasi-elastic vector meson production
28829         IF(IFLA.EQ.113) THEN
28830           KP = 1
28831         ELSE IF(IFLA.EQ.223) THEN
28832           KP = 2
28833         ELSE IF(IFLA.EQ.333) THEN
28834           KP = 3
28835         ELSE IF(IFLA.EQ.92) THEN
28836           KP = 4
28837 C  quasi-elastic production of h*
28838         ELSE IF(IFLA.EQ.91) THEN
28839           RMASS = 0.35D0
28840           RETURN
28841 C  elastic hadron scattering
28842         ELSE
28843           RMASS = PHO_PMASS(IFLA,1)
28844           IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
28845      &      'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
28846           RETURN
28847         ENDIF
28848 C
28849 C  sample mass of vector mesonsn / two-pi background
28850         XI = DT_RNDM(RMASS) + EPS
28851 C  binary search
28852         IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
28853           KMIN=1
28854           KMAX=NSTEP
28855  300      CONTINUE
28856           IF((KMAX-KMIN).EQ.1) GOTO 400
28857           KK=(KMAX+KMIN)/2
28858           IF(XI.LE.XMC(KP,KK)) THEN
28859             KMAX=KK
28860           ELSE
28861             KMIN=KK
28862           ENDIF
28863           GOTO 300
28864  400      CONTINUE
28865         ELSE
28866           WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
28867           WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
28868      &      KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
28869           CALL PHO_ABORT
28870         ENDIF
28871 C  fine interpolation
28872         RMASS = RMA(KP,KMIN)+
28873      &          (RMA(KP,KMAX)-RMA(KP,KMIN))/
28874      &          (XMC(KP,KMAX)-XMC(KP,KMIN))
28875      &          *(XI-XMC(KP,KMIN))
28876         IF(IDEB(35).GE.20) THEN
28877           IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
28878      &      'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
28879      &      RMA(KP,KMIN),RMA(KP,KMAX),RMASS
28880           WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
28881      &      IFLA,RMASS
28882         ENDIF
28883         ICALL(KP) = ICALL(KP)+1
28884
28885       ENDIF
28886       END
28887
28888 CDECK  ID>, PHO_DSIGDM
28889       SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
28890 C**********************************************************************
28891 C
28892 C     differential cross section DSIG/DM of low mass enhancement
28893 C
28894 C     input:   RMA(4,NTABM)   mass values
28895 C     output:  XMA(4,NTABM)   DSIG/DM of resonances
28896 C                  1          rho production
28897 C                  2          omega production
28898 C                  3          phi production
28899 C                  4          pi-pi continuum
28900 C
28901 C**********************************************************************
28902       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28903       SAVE
28904
28905       PARAMETER ( EPS  = 1.D-10 )
28906
28907       PARAMETER(NTABM=50)
28908       DIMENSION XMA(4,NTABM),RMA(4,NTABM)
28909
28910 C  input/output channels
28911       INTEGER LI,LO
28912       COMMON /POINOU/ LI,LO
28913 C  event debugging information
28914       INTEGER NMAXD
28915       PARAMETER (NMAXD=100)
28916       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28917      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28918       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28919      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28920 C  model switches and parameters
28921       CHARACTER*8 MDLNA
28922       INTEGER ISWMDL,IPAMDL
28923       DOUBLE PRECISION PARMDL
28924       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28925 C  parameters of the "simple" Vector Dominance Model
28926       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28927       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28928
28929       PIMASS = 0.135
28930 C  rho meson shape (mass dependent width)
28931       QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
28932       DO 100 I=1,NSTEP
28933         XMASS = RMA(1,I)
28934         QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
28935         GAMMA = GAMM(1)*(QQ/QRES)**3
28936         XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
28937      &             /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
28938  100  CONTINUE
28939 C  omega/phi meson (constant width)
28940       DO 200 K=2,3
28941         DO 300 I=1,NSTEP
28942           XMASS = RMA(K,I)
28943           XMA(K,I) = XMASS*GAMM(K)
28944      &               /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
28945  300    CONTINUE
28946  200  CONTINUE
28947 C  pi-pi continuum
28948       DO 400 I=1,NSTEP
28949         XMASS = RMA(4,I)
28950         XMA(4,I) = (XMASS-0.29D0)**2/XMASS
28951  400  CONTINUE
28952
28953       END
28954
28955 CDECK  ID>, PHO_SDECAY
28956       SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
28957 C**********************************************************************
28958 C
28959 C     decay of single resonance of /POEVT1/:
28960 C       decay in helicity frame according to polarization, isotropic
28961 C       decay and decay with limited transverse phase space possible
28962 C
28963 C     ATTENTION:
28964 C     reference to particle number of CPC has to exist
28965 C
28966 C     input:   NPOS    position in /POEVT1/
28967 C              ISP     0  decay according to phase space
28968 C                      1  decay according to transversal polarization
28969 C                      2  decay according to longitudinal polarization
28970 C                      3  decay with limited phase space
28971 C              ILEV    decay mode to use
28972 C                      1 strong only
28973 C                      2 strong and ew of tau, charm, and bottom
28974 C                      3 strong and electro-weak decays
28975 C                      negative: remove mother resonance after decay
28976 C
28977 C     output:  /POEVT1/,/POEVT2/ final particles according to decay mode
28978 C
28979 C**********************************************************************
28980       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28981       SAVE
28982
28983       PARAMETER ( EPS  = 1.D-15,
28984      &            DEPS = 1.D-10 )
28985
28986 C  input/output channels
28987       INTEGER LI,LO
28988       COMMON /POINOU/ LI,LO
28989 C  event debugging information
28990       INTEGER NMAXD
28991       PARAMETER (NMAXD=100)
28992       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28993      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28994       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28995      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28996 C  model switches and parameters
28997       CHARACTER*8 MDLNA
28998       INTEGER ISWMDL,IPAMDL
28999       DOUBLE PRECISION PARMDL
29000       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29001 C  some constants
29002       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29003       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29004      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29005
29006 C  standard particle data interface
29007       INTEGER NMXHEP
29008
29009       PARAMETER (NMXHEP=4000)
29010
29011       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
29012       DOUBLE PRECISION PHEP,VHEP
29013       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
29014      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
29015      &                VHEP(4,NMXHEP)
29016 C  extension to standard particle data interface (PHOJET specific)
29017       INTEGER IMPART,IPHIST,ICOLOR
29018       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
29019
29020 C  general particle data
29021       double precision xm_list,tau_list,gam_list,
29022      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29023      &  xm_bb82_list,xm_bb102_list
29024       integer          ich3_list,iba3_list,iq_list,
29025      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
29026       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29027      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
29028      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29029      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29030      &  ich3_list(300),iba3_list(300),iq_list(3,300),
29031      &  id_psm_list(6,6),id_vem_list(6,6),
29032      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
29033 C  particle decay data
29034       double precision wg_sec_list
29035       integer          idec_list,isec_list
29036       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
29037      &  isec_list(3,500)
29038 C  auxiliary data for three particle decay
29039       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29040       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29041
29042       DIMENSION WGHD(20),KCH(20),ID(3)
29043
29044       IMODE = ABS(ILEV)
29045       IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
29046      &  'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
29047
29048 C  comment entry
29049       IF(ISTHEP(NPOS).GT.11) RETURN
29050
29051 C  particle stable?
29052       IDcpc = IMPART(NPOS)
29053       IF(IDcpc.EQ.0) return
29054       if(idec_list(1,IDcpc).eq.0) return
29055       IDabs = iabs(IDcpc)
29056
29057 C  different decay modi (times)
29058       IF(IMODE.EQ.1) THEN
29059         if(idec_list(1,IDabs).ne.1) return
29060       ELSE IF(IMODE.EQ.2) THEN
29061         if(idec_list(1,IDabs).gt.2) return
29062       ELSE IF(IMODE.EQ.3) THEN
29063         if(idec_list(1,IDabs).gt.3) return
29064       ELSE
29065         WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
29066         CALL PHO_ABORT
29067       ENDIF
29068
29069 C  decay products, check for mass limitations
29070       K = 0
29071       WGSUM = 0.D0
29072       AMIST = PHEP(5,NPOS)
29073       DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
29074         AMSUM = 0.D0
29075         DO 200 L=1,3
29076           ID(L) = isec_list(L,I)
29077           IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
29078  200    CONTINUE
29079         IF(AMSUM.LT.AMIST) THEN
29080           K = K+1
29081           WGHD(K) = wg_sec_list(I)
29082           KCH(K) = I
29083         ENDIF
29084  100  CONTINUE
29085       IF(K.EQ.0)THEN
29086         WRITE(LO,'(/1X,A,I6,3E12.4)')
29087      &    'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29088      &    NPOS,AMIST,AMSUM
29089         CALL PHO_PREVNT(0)
29090         RETURN
29091       ENDIF
29092
29093 C  sample new decay channel
29094       XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29095       K = 0
29096       WGSUM = 0.D0
29097  500  CONTINUE
29098         K = K+1
29099         WGSUM = WGSUM+WGHD(K)
29100       IF(XI.GT.WGSUM) GOTO 500
29101       IK = KCH(K)
29102       ID(1) = isec_list(1,IK)
29103       ID(2) = isec_list(2,IK)
29104       ID(3) = isec_list(3,IK)
29105       if(IDcpc.lt.0) then
29106         ID(1) = ipho_anti(ID(1))
29107         ID(2) = ipho_anti(ID(2))
29108         ID(3) = ipho_anti(ID(3))
29109       endif
29110
29111 C  rotation
29112       PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29113       CXS = PHEP(1,NPOS)/PTOT
29114       CYS = PHEP(2,NPOS)/PTOT
29115       CZS = PHEP(3,NPOS)/PTOT
29116 C  boost
29117       GBET = PTOT/AMIST
29118       GAM = PHEP(4,NPOS)/AMIST
29119
29120       IF(ID(3).EQ.0) THEN
29121 C  two particle decay
29122         CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29123       ELSE
29124 C  three particle decay
29125         CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29126      &    pho_pmass(ID(3),0),ISP)
29127       ENDIF
29128
29129       IF(ILEV.LT.0) THEN
29130         IF(NHEP.NE.NPOS) THEN
29131           WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29132      &      'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29133           CALL PHO_ABORT
29134         ENDIF
29135         IMO1 = JMOHEP(1,NPOS)
29136         IMO2 = JMOHEP(2,NPOS)
29137         NHEP = NHEP-1
29138       ELSE
29139         IMO1 = NPOS
29140         IMO2 = 0
29141       ENDIF
29142       IPH1 = IPHIST(1,NPOS)
29143       IPH2 = IPHIST(2,NPOS)
29144
29145 C  back transformation and registration
29146       DO 300 I=1,3
29147         IF(ID(I).NE.0) THEN
29148           CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29149      &      PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29150           XX = PTOT*CX
29151           YY = PTOT*CY
29152           ZZ = PTOT*CZ
29153           CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29154      &      IPH1,IPH2,0,0,IPOS,1)
29155         ENDIF
29156  300  CONTINUE
29157
29158  400  CONTINUE
29159 C  debug output
29160       IF(IDEB(36).GE.20) THEN
29161         WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29162      &                        '--------------------'
29163         CALL PHO_PREVNT(0)
29164       ENDIF
29165
29166       END
29167
29168 CDECK  ID>, PHO_SDECY2
29169       SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29170 C**********************************************************************
29171 C
29172 C     isotropic/anisotropic two particle decay in CM system,
29173 C     (transversely/longitudinally polarized boson into two
29174 C     pseudo-scalar mesons)
29175 C
29176 C**********************************************************************
29177       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29178       SAVE
29179
29180 C  input/output channels
29181       INTEGER LI,LO
29182       COMMON /POINOU/ LI,LO
29183 C  auxiliary data for three particle decay
29184       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29185       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29186
29187       UMO2=UMO*UMO
29188       AM11=AM1*AM1
29189       AM22=AM2*AM2
29190       ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29191       ECM(2)=UMO-ECM(1)
29192       WAU=ECM(1)*ECM(1)-AM11
29193       IF(WAU.LT.0.D0) THEN
29194         WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29195         CALL PHO_ABORT
29196       ENDIF
29197       PCM(1)=SQRT(WAU)
29198       PCM(2)=PCM(1)
29199
29200       CALL PHO_SFECFE(SIF(1),COF(1))
29201       IF(ISP.EQ.0) THEN
29202 C  no polarization
29203         COD(1)  = 2.D0*DT_RNDM(UMO)-1.D0
29204       ELSE IF(ISP.EQ.1) THEN
29205 C  transverse polarization
29206  400    CONTINUE
29207           COD(1)  = 2.D0*DT_RNDM(AM22)-1.D0
29208           SID12 = 1.D0-COD(1)*COD(1)
29209         IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29210       ELSE IF(ISP.EQ.2) THEN
29211 C  longitudinal polarization
29212  500    CONTINUE
29213           COD(1)  = 2.D0*DT_RNDM(AM2)-1.D0
29214           COD12 = COD(1)*COD(1)
29215         IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29216       ELSE
29217         WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29218      &    'invalid polarization',ISP
29219         CALL PHO_ABORT
29220       ENDIF
29221
29222       COD(2) = -COD(1)
29223       COF(2) = -COF(1)
29224       SIF(2) = -SIF(1)
29225
29226       END
29227
29228 CDECK  ID>, PHO_SDECY3
29229       SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29230 C**********************************************************************
29231 C
29232 C     isotropic/anisotropic three particle decay in CM system,
29233 C     (transversely/longitudinally polarized boson into three
29234 C     pseudo-scalar mesons)
29235 C
29236 C**********************************************************************
29237       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29238       SAVE
29239
29240       PARAMETER ( DEPS   = 1.D-30,
29241      &            EPS    = 1.D-15 )
29242
29243 C  input/output channels
29244       INTEGER LI,LO
29245       COMMON /POINOU/ LI,LO
29246 C  auxiliary data for three particle decay
29247       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29248       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29249
29250       DIMENSION F(5),XX(5)
29251
29252 C  calculation of maximum of S2 phase space weight
29253       UMOO=UMO+UMO
29254       GU=(AM2+AM3)**2
29255       GO=(UMO-AM1)**2
29256       UFAK=1.0000000000001D0
29257       IF (GU.GT.GO) UFAK=0.99999999999999D0
29258       OFAK=2.D0-UFAK
29259       GU=GU*UFAK
29260       GO=GO*OFAK
29261       DS2=(GO-GU)/99.D0
29262       AM11=AM1*AM1
29263       AM22=AM2*AM2
29264       AM33=AM3*AM3
29265       UMO2=UMO*UMO
29266       RHO2=0.D0
29267       S22=GU
29268       DO 124 I=1,100
29269         S21=S22
29270         S22=GU+(I-1.D0)*DS2
29271         RHO1=RHO2
29272         RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29273         IF(RHO2.LT.RHO1) GOTO 125
29274   124 CONTINUE
29275
29276   125 CONTINUE
29277       S2SUP=(S22-S21)/2.D0+S21
29278       SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29279      &       /(S2SUP+EPS)
29280       SUPRHO=SUPRHO*1.05D0
29281       XO=S21-DS2
29282       IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29283       IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29284       XX(1)=XO
29285       XX(3)=S22
29286       X1=(XO+S22)*0.5D0
29287       XX(2)=X1
29288       F(3)=RHO2
29289       F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29290       F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29291       DO 126 I=1,16
29292         X4=(XX(1)+XX(2))*0.5D0
29293         X5=(XX(2)+XX(3))*0.5D0
29294         F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29295         F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29296         XX(4)=X4
29297         XX(5)=X5
29298         DO 128 II=1,5
29299           IA=II
29300           DO 131 III=IA,5
29301             IF(F(II).LT.F(III)) THEN
29302               FH=F(II)
29303               F(II)=F(III)
29304               F(III)=FH
29305               FH=XX(II)
29306               XX(II)=XX(III)
29307               XX(III)=FH
29308             ENDIF
29309  131      CONTINUE
29310  128    CONTINUE
29311         SUPRHO=F(1)
29312         S2SUP=XX(1)
29313         DO 129 II=1,3
29314           IA=II
29315           DO 130 III=IA,3
29316             IF (XX(II).LT.XX(III)) THEN
29317               FH=F(II)
29318               F(II)=F(III)
29319               F(III)=FH
29320               FH=XX(II)
29321               XX(II)=XX(III)
29322               XX(III)=FH
29323             ENDIF
29324  130      CONTINUE
29325  129    CONTINUE
29326  126  CONTINUE
29327
29328       AM23=(AM2+AM3)**2
29329
29330 C  selection of S1
29331       ITH=0
29332  200  CONTINUE
29333         ITH=ITH+1
29334         IF(ITH.GT.200) THEN
29335           WRITE(LO,'(/1X,A,I10)')
29336      &      'PHO_SDECY3:ERROR: too many iterations',ITH
29337           CALL PHO_ABORT
29338         ENDIF
29339         S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29340         Y=DT_RNDM(AM23)*SUPRHO
29341         RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29342       IF(Y.GT.RHO) GOTO 200
29343
29344 C  selection of S2
29345       S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29346      &   /(2.D0*S2)-RHO/2.D0
29347       S3=UMO2+AM11+AM22+AM33-S1-S2
29348       ECM(1)=(UMO2+AM11-S2)/UMOO
29349       ECM(2)=(UMO2+AM22-S3)/UMOO
29350       ECM(3)=(UMO2+AM33-S1)/UMOO
29351       PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29352       PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29353       PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29354
29355 C  calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29356       IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29357         COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29358       ELSE
29359         COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29360       ENDIF
29361       COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29362      &        /(2.D0*PCM(2)*PCM(3))
29363       SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29364       SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29365       COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29366
29367 C  selection of the sperical coordinates of particle 3
29368       CALL PHO_SFECFE(SIF(3),COF(3))
29369       IF(ISP.EQ.0) THEN
29370 C  no polarization
29371         COD(3)  = 2.D0*DT_RNDM(S2)-1.D0
29372       ELSE IF(ISP.EQ.1) THEN
29373 C  transverse polarization
29374  400    CONTINUE
29375           COD(3)  = 2.D0*DT_RNDM(S1)-1.D0
29376           SID32 = 1.D0-COD(3)*COD(3)
29377         IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29378       ELSE IF(ISP.EQ.2) THEN
29379 C  longitudinal polarization
29380  500    CONTINUE
29381           COD(3)  = 2.D0*DT_RNDM(COSTH2)-1.D0
29382           COD32 = COD(3)*COD(3)
29383         IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29384       ELSE
29385         WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29386      &    'invalid polarization',ISP
29387         CALL PHO_ABORT
29388       ENDIF
29389
29390 C  selection of the rotation angle of p1-p2 plane along p3
29391       IF(ISP.EQ.0) THEN
29392         CALL PHO_SFECFE(SFE,CFE)
29393       ELSE
29394         SFE = 0.D0
29395         CFE = 1.D0
29396       ENDIF
29397       CX11=-COSTH1
29398       CY11=SINTH1*CFE
29399       CZ11=SINTH1*SFE
29400       CX22=-COSTH2
29401       CY22=-SINTH2*CFE
29402       CZ22=-SINTH2*SFE
29403
29404       SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29405       COD(1)=CX11*COD(3)+CZ11*SID3
29406       IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29407         WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29408      &    COD(1),COF(3),SID3,CX11,CZ11
29409         CALL PHO_PREVNT(-1)
29410       ENDIF
29411
29412       SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29413       COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29414       SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29415       COD(2)=CX22*COD(3)+CZ22*SID3
29416       SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29417       COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29418       SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29419
29420       END
29421
29422 CDECK  ID>, PHO_DFMASS
29423       DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29424 C**********************************************************************
29425 C
29426 C     sampling of Mx diffractive mass distribution within
29427 C              limits XMIN, XMAX
29428 C
29429 C     input:    XMIN,XMAX     mass limitations (GeV)
29430 C               PREF2         original particle mass/ reference mass
29431 C                             (squared, GeV**2)
29432 C               PVIRT2        particle virtuality
29433 C               IMODE         M**2 mass distribution
29434 C                             1      1/(M**2+Q**2)
29435 C                             2      1/(M**2+Q**2)**alpha
29436 C                            -1      1/(M**2-Mref**2+Q**2)
29437 C                            -2      1/(M**2-Mref**2+Q**2)**alpha
29438 C
29439 C     output:   diffractive mass (GeV)
29440 C
29441 C**********************************************************************
29442       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29443       SAVE
29444
29445       PARAMETER(EPS  = 1.D-10)
29446
29447 C  input/output channels
29448       INTEGER LI,LO
29449       COMMON /POINOU/ LI,LO
29450 C  event debugging information
29451       INTEGER NMAXD
29452       PARAMETER (NMAXD=100)
29453       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29454      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29455       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29456      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29457 C  model switches and parameters
29458       CHARACTER*8 MDLNA
29459       INTEGER ISWMDL,IPAMDL
29460       DOUBLE PRECISION PARMDL
29461       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29462 C  some constants
29463       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29464       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29465      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29466
29467       IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29468         WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29469      &    'invalid mass limits',XMIN,XMAX,PREF2
29470         CALL PHO_PREVNT(-1)
29471         PHO_DFMASS = 0.135D0
29472         RETURN
29473       ENDIF
29474
29475       IF(IMODE.GT.0) THEN
29476         PM2 = -PVIRT2
29477       ELSE
29478         PM2 = PREF2 - PVIRT2
29479       ENDIF
29480
29481 C  critical pomeron
29482       IF(ABS(IMODE).EQ.1) THEN
29483         XMIN2 = LOG(XMIN**2-PM2)
29484         XMAX2 = LOG(XMAX**2-PM2)
29485         XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29486         XMA2 = EXP(XI)+PM2
29487
29488 C  supercritical pomeron
29489       ELSE IF(ABS(IMODE).EQ.2) THEN
29490         DDELTA = 1.D0-PARMDL(48)
29491         XMIN2 = (XMIN**2-PM2)**DDELTA
29492         XMAX2 = (XMAX**2-PM2)**DDELTA
29493         XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29494         XMA2 = XI**(1.D0/DDELTA)+PM2
29495       ELSE
29496         WRITE(LO,'(/,1X,A,I3)')
29497      &    'PHO_DFMASS:ERROR: unsupported mode',IMODE
29498         CALL PHO_ABORT
29499       ENDIF
29500
29501       PHO_DFMASS = SQRT(XMA2)
29502 C  debug output
29503       IF(IDEB(43).GE.15) THEN
29504         WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29505      &    XMIN,XMAX,PREF2,SQRT(XMA2)
29506       ENDIF
29507
29508       END
29509
29510 CDECK  ID>, PHO_DIFSLP
29511       SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29512      &                  TT,SLWGHT,IREJ)
29513 C**********************************************************************
29514 C
29515 C     sampling of T  (Mandelstam variable) distribution within
29516 C     certain limits TMIN, TMAX
29517 C
29518 C     input:    IDF1,2     type of diffractive vertex
29519 C                           0   elastic/quasi-elastic scattering
29520 C                           1   diffraction dissociation
29521 C               IVEC1,2    vector meson IDs in case of quasi-elastic
29522 C                          scattering, otherwise 0
29523 C               XM1        mass of diffractive system 1 (GeV)
29524 C               XM2        mass of diffractive system 2 (GeV)
29525 C               XMX        max. mass of diffractive system (GeV)
29526 C
29527 C     output:   TT         squared momentum transfer ( < 0, GeV**2)
29528 C               SLWGHT     weight to allow for mass-dependent slope
29529 C               IREJ       0  successful sampling
29530 C                          1  masses too big for given T range
29531 C
29532 C**********************************************************************
29533       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29534       SAVE
29535
29536       PARAMETER(EPS  = 1.D-10)
29537
29538 C  input/output channels
29539       INTEGER LI,LO
29540       COMMON /POINOU/ LI,LO
29541 C  event debugging information
29542       INTEGER NMAXD
29543       PARAMETER (NMAXD=100)
29544       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29545      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29546       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29547      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29548 C  model switches and parameters
29549       CHARACTER*8 MDLNA
29550       INTEGER ISWMDL,IPAMDL
29551       DOUBLE PRECISION PARMDL
29552       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29553 C  internal rejection counters
29554       INTEGER NMXJ
29555       PARAMETER (NMXJ=60)
29556       CHARACTER*10 REJTIT
29557       INTEGER IFAIL
29558       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29559 C  c.m. kinematics of diffraction
29560       INTEGER NPOSD
29561       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29562      &                 SIDD,CODD,SIFD,COFD,PDCMS
29563       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29564      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29565 C  cross sections
29566       INTEGER IPFIL,IFAFIL,IFBFIL
29567       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29568      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29569      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29570      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29571      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29572       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29573      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29574      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29575      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29576      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29577      &                IPFIL,IFAFIL,IFBFIL
29578 C  Reggeon phenomenology parameters
29579       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29580      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29581       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29582      &                ALREG,ALREGP,GR(2),B0REG(2),
29583      &                GPPP,GPPR,B0PPP,B0PPR,
29584      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29585 C  parameters of 2x2 channel model
29586       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29587       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29588 C  parameters of the "simple" Vector Dominance Model
29589       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29590       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29591 C  some constants
29592       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29593       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29594      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29595
29596       IREJ = 0
29597       XM12 = XM1**2
29598       XM22 = XM2**2
29599       SS = ECMD**2
29600 C
29601 C  range of momentum transfer t
29602       TMIN = -PARMDL(68)
29603       TMAX = -PARMDL(69)
29604 C  determine min. abs(t) necessary to produce masses
29605       PCM2 = PCMD**2
29606       PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29607       IF(PCMP2.LE.0.D0) THEN
29608         IREJ = 1
29609         TT = 0.D0
29610         RETURN
29611       ENDIF
29612       TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29613      &        -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29614 C
29615       IF(TMINP.LT.TMAX) THEN
29616         IF(IDEB(44).GE.3) THEN
29617           WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29618      &      'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29619      &      XM1,XM2,TMIN,TMAX,TMINP
29620         ENDIF
29621         IFAIL(32) = IFAIL(32)+1
29622         IREJ = 1
29623         TT = 0.D0
29624         RETURN
29625       ENDIF
29626       TMINA = MIN(TMIN,TMINP)
29627 C
29628 C  calculation of slope (mass-dependent parametrization)
29629       IF(IDF1+IDF2.GT.0) THEN
29630 C  diffraction dissociation
29631         XMP12 = XM1**2+PVIRTD(1)
29632         XMP22 = XM2**2+PVIRTD(2)
29633         XMX1 = SQRT(XMP12)
29634         XMX2 = SQRT(XMP22)
29635         CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29636         FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29637         SLOPE = DBLE(IDF1+IDF2)*B0PPP
29638      &    +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29639      &    /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29640         SLOPE = MAX(SLOPE,1.D0)
29641 C
29642         XMA1 = XMX
29643         XMA2 = XMX
29644         IF(IDF1.EQ.0) THEN
29645           XMA1 = XM1
29646         ELSE IF(IDF1.EQ.0) THEN
29647           XMA2 = XM2
29648         ENDIF
29649         XMP12 = XMA1**2+PVIRTD(1)
29650         XMP22 = XMA2**2+PVIRTD(2)
29651         XMX1 = SQRT(XMP12)
29652         XMX2 = SQRT(XMP22)
29653         CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29654         SLMIN = DBLE(IDF1+IDF2)*B0PPP
29655      &    +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29656      &    /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29657         SLMIN = MAX(SLMIN,1.D0)
29658       ELSE
29659 C  elastic/quasi-elastic scattering
29660         IF(ISWMDL(13).EQ.0) THEN
29661 C  external slope values
29662           PRINT LO,'PHO_DIFSLP:ERROR: this option is not installed !'
29663           CALL PHO_ABORT
29664         ELSE IF(ISWMDL(13).EQ.1) THEN
29665 C  model slopes
29666           IF(IVEC1*IVEC2.EQ.0) THEN
29667             SLOPE = SLOEL
29668           ELSE
29669             SLOPE = SLOVM(IVEC1,IVEC2)
29670           ENDIF
29671           SLMIN = SLOPE
29672         ELSE
29673           WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29674      &      ISWMDL(13)
29675           CALL PHO_ABORT
29676         ENDIF
29677       ENDIF
29678 C
29679 C  determine max. abs(t) to avoid underflows
29680       TMAXP = -25.D0/SLOPE
29681       TMAXA = MAX(TMAX,TMAXP)
29682 C
29683       IF(TMINA.LT.TMAXA) THEN
29684         IF(IDEB(44).GE.3) THEN
29685           WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29686      &      'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29687      &      XM1,XM2,TMINA,TMAXA,SLOPE
29688         ENDIF
29689         IFAIL(32) = IFAIL(32)+1
29690         IREJ = 1
29691         TT = 0.D0
29692         RETURN
29693       ENDIF
29694 C
29695 C  sampling from corrected range of T
29696       TMINE = EXP(SLMIN*TMINA)
29697       TMAXE = EXP(SLMIN*TMAXA)
29698       XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29699       TT = LOG(XI)/SLMIN
29700       SLWGHT = EXP((SLOPE-SLMIN)*TT)
29701 C
29702 C  debug output
29703       IF(IDEB(44).GE.15) THEN
29704         WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29705      &    'PHO_DIFSLP: sampled momentum transfer:',TT,
29706      &    'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29707      &    'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29708       ENDIF
29709       END
29710
29711 CDECK  ID>, PHO_DIFKIN
29712       SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29713 C**********************************************************************
29714 C
29715 C     calculation of diffractive kinematics
29716 C
29717 C     input:    XMP1         mass of outgoing particle system 1 (GeV)
29718 C               XMP2         mass of outgoing particle system 2 (GeV)
29719 C               TT           momentum transfer    (GeV**2, negative)
29720 C
29721 C     output:   PMOM1(5)     four momentum of outgoing system 1
29722 C               PMOM2(5)     four momentum of outgoing system 2
29723 C               IREJ         0    kinematics consistent
29724 C                            1    kinematics inconsistent
29725 C
29726 C**********************************************************************
29727       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29728       SAVE
29729
29730       PARAMETER(EPS  = 1.D-10,
29731      &          DEPS = 0.001)
29732
29733 C  input/output channels
29734       INTEGER LI,LO
29735       COMMON /POINOU/ LI,LO
29736 C  event debugging information
29737       INTEGER NMAXD
29738       PARAMETER (NMAXD=100)
29739       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29740      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29741       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29742      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29743 C  c.m. kinematics of diffraction
29744       INTEGER NPOSD
29745       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29746      &                 SIDD,CODD,SIFD,COFD,PDCMS
29747       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29748      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29749 C  some constants
29750       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29751       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29752      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29753
29754       DOUBLE PRECISION PMOM1,PMOM2
29755       DIMENSION PMOM1(5),PMOM2(5)
29756
29757 C  debug output
29758       IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29759      &    'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29760      &    ECMD,PCMD,XMP1,XMP2,TT
29761
29762 C  general kinematic constraints
29763       IREJ = 1
29764       IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29765
29766 C  new squared cms momentum
29767       XMP12 = XMP1**2
29768       XMP22 = XMP2**2
29769       SS = ECMD**2
29770       PCM2 = PCMD**2
29771       PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29772
29773 C  new longitudinal/transverse momentum
29774       E1I = SQRT(PCM2+PMASSD(1)**2)
29775       E1F = SQRT(PCMP2+XMP12)
29776       E2F = SQRT(PCMP2+XMP22)
29777       PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29778       PTRAN = PCMP2-PLONG**2
29779
29780 C  check consistency of kinematics
29781       IF(PTRAN.LT.0.D0) THEN
29782         IF(IDEB(49).GE.1) THEN
29783           WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29784      &      'inconsistent kinematics in event call: ',KEVENT
29785           WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
29786      &      'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
29787      &      XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
29788         ENDIF
29789         IREJ = 1
29790         RETURN
29791       ELSE
29792         PTRAN = SQRT(PTRAN)
29793       ENDIF
29794       XI = PI2*DT_RNDM(PTRAN)
29795
29796 C  outgoing momenta in cm. system
29797       PMOM1(4) = E1F
29798       PMOM1(1) = PTRAN*COS(XI)
29799       PMOM1(2) = PTRAN*SIN(XI)
29800       PMOM1(3) = PLONG
29801       PMOM1(5) = XMP1
29802
29803       PMOM2(4) = E2F
29804       PMOM2(1) = -PMOM1(1)
29805       PMOM2(2) = -PMOM1(2)
29806       PMOM2(3) = -PLONG
29807       PMOM2(5) = XMP2
29808       IREJ = 0
29809
29810 C  debug output / precision check
29811       IF(IDEB(49).GE.0) THEN
29812 C  check kinematics
29813         XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
29814      &        -PMOM1(1)**2-PMOM1(2)**2
29815         XM1 = SIGN(SQRT(ABS(XM1)),XM1)
29816         XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
29817      &        -PMOM2(1)**2-PMOM2(2)**2
29818         XM2 = SIGN(SQRT(ABS(XM2)),XM2)
29819         IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
29820           WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
29821      &      'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
29822      &      XMP1,XM1,XMP2,XM2
29823           CALL PHO_PREVNT(-1)
29824         ENDIF
29825 C  output
29826         IF(IDEB(49).GT.10) THEN
29827           WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
29828      &      'PHO_DIFKIN: P1',PMOM1,'                 P2',PMOM2
29829         ENDIF
29830       ENDIF
29831
29832       END
29833
29834 CDECK  ID>, PHO_VECRES
29835       SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
29836 C**********************************************************************
29837 C
29838 C     sampling of vector meson resonance in diffractive processes
29839 C     (nothing done for hadrons)
29840 C
29841 C     input:   /POSVDM/     VDMFAC factors
29842 C
29843 C     output:  IVEC         0   incoming hadron
29844 C                           1   rho 0
29845 C                           2   omega
29846 C                           3   phi
29847 C                           4   pi+/pi- background
29848 C              RMASS        mass of vector meson (GeV)
29849 C              IDPDG        particle ID according to PDG
29850 C              IDBAM        particle ID according to CPC
29851 C
29852 C**********************************************************************
29853       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29854       SAVE
29855
29856       PARAMETER(EPS  = 1.D-10)
29857
29858 C  input/output channels
29859       INTEGER LI,LO
29860       COMMON /POINOU/ LI,LO
29861 C  event debugging information
29862       INTEGER NMAXD
29863       PARAMETER (NMAXD=100)
29864       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29865      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29866       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29867      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29868 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
29869       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
29870       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
29871       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
29872      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
29873 C  parameters of the "simple" Vector Dominance Model
29874       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29875       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29876 C  some constants
29877       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29878       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29879      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29880
29881 C  particle code translation
29882       DIMENSION ITRANS(4)
29883 C                  rho0,omega,phi,pi+/pi-
29884       DATA ITRANS /113, 223, 333, 92 /
29885
29886       IDPDO = IDPDG
29887 C
29888 C  vector meson production
29889       IF(IDPDG.EQ.22) THEN
29890         XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
29891         SUM = 0.D0
29892         DO 55 K=1,4
29893           SUM = SUM + VMFA(K)
29894           IF(XI.LE.SUM) GOTO 65
29895  55     CONTINUE
29896  65     CONTINUE
29897 C
29898         IDPDG = ITRANS(K)
29899         IDBAM = ipho_pdg2id(IDPDG)
29900         IVEC  = K
29901 C  sample mass of vector meson
29902         CALL PHO_SAMASS(IDPDG,RMASS)
29903
29904 C  hadronic resonance of multi-pomeron coupling
29905       ELSE IF(IDPDG.EQ.990) THEN
29906         K = 4
29907         IDPDG = 91
29908         IDBAM = ipho_pdg2id(IDPDG)
29909         IVEC  = 4
29910 C  sample mass of two-pion system
29911         CALL PHO_SAMASS(IDPDG,RMASS)
29912
29913 C  hadron remnants in inucleus interactions
29914       ELSE IF(IDPDG.EQ.81) THEN
29915         IF(IHFLD(1,1).EQ.0) THEN
29916           CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
29917           CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29918         ELSE
29919           CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
29920         ENDIF
29921         RMAS1 = PHO_PMASS(IDBA1,0)
29922         RMAS2 = PHO_PMASS(IDBA2,0)
29923         IF((IDBA2.NE.0).AND.
29924      &    (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29925           IDBAM = IDBA2
29926           RMASS = RMAS2
29927         ELSE
29928           IDBAM = IDBA1
29929           RMASS = RMAS1
29930         ENDIF
29931         IDPDG = IPHO_ID2PDG(IDBAM)
29932         IVEC = 0
29933       ELSE IF(IDPDG.EQ.82) THEN
29934         IF(IHFLD(2,1).EQ.0) THEN
29935           CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
29936           CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29937         ELSE
29938           CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
29939         ENDIF
29940         RMAS1 = PHO_PMASS(IDBA1,0)
29941         RMAS2 = PHO_PMASS(IDBA2,0)
29942         IF((IDBA2.NE.0).AND.
29943      &    (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29944           IDBAM = IDBA2
29945           RMASS = RMAS2
29946         ELSE
29947           IDBAM = IDBA1
29948           RMASS = RMAS1
29949         ENDIF
29950         IDPDG = IPHO_ID2PDG(IDBAM)
29951         IVEC = 0
29952       ENDIF
29953 C  debug output
29954       IF(IDEB(47).GE.5) THEN
29955         WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
29956      &    'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
29957      &    IDPDO,IDPDG,IDBAM,RMASS
29958       ENDIF
29959
29960       END
29961
29962 CDECK  ID>, PHO_DIFRES
29963       SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
29964      &                  IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
29965 C**********************************************************************
29966 C
29967 C     list of resonance states for low mass resonances
29968 C
29969 C     input:   IDMOTH       PDG ID of mother particle
29970 C              IVAL1,2      quarks (photon only)
29971 C
29972 C     output:  IDPDG        list of PDG IDs for possible resonances
29973 C              IDBAM        list of corresponding CPC IDs
29974 C              RMASS        mass
29975 C              RGAMS        decay width
29976 C              RMASS        additional weight factor
29977 C              LISTL        entries in current list
29978 C
29979 C**********************************************************************
29980       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29981       SAVE
29982
29983       DIMENSION  IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
29984
29985       PARAMETER (EPS    =  1.D-10,
29986      &           DEPS   =  1.D-15)
29987
29988 C  input/output channels
29989       INTEGER LI,LO
29990       COMMON /POINOU/ LI,LO
29991 C  event debugging information
29992       INTEGER NMAXD
29993       PARAMETER (NMAXD=100)
29994       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29995      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29996       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29997      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29998 C  particle ID translation table
29999       integer         ID_pdg_list,ID_list,ID_pdg_max
30000       character*12    name_list
30001       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
30002      &                ID_pdg_max
30003 C  general particle data
30004       double precision xm_list,tau_list,gam_list,
30005      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30006      &  xm_bb82_list,xm_bb102_list
30007       integer          ich3_list,iba3_list,iq_list,
30008      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
30009       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30010      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
30011      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30012      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30013      &  ich3_list(300),iba3_list(300),iq_list(3,300),
30014      &  id_psm_list(6,6),id_vem_list(6,6),
30015      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
30016
30017       DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
30018       DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
30019      &            12212, 42212, -12212, -42212,
30020      &            8*0 /
30021       DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
30022      &            1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
30023      &            8*1.D0 /
30024
30025       DATA init /0/
30026
30027 C  initialize table
30028       if(init.eq.0) then
30029         do i=1,20
30030           if(IRPDG(i).ne.0) then
30031             IRBAM(i) = ipho_pdg2id(IRPDG(i))
30032           endif
30033         enddo
30034         init = 1
30035       endif
30036
30037 C  copy table with particles and isospin weights
30038       LISTL = 0
30039       IF(IDMOTH.EQ.22) THEN
30040         I1 = 4
30041         I2 = 8
30042       ELSE IF(IDMOTH.EQ.2212) THEN
30043         I1 = 9
30044         I2 = 10
30045       ELSE IF(IDMOTH.EQ.-2212) THEN
30046         I1 = 11
30047         I2 = 12
30048       ELSE
30049         RETURN
30050       ENDIF
30051
30052       DO 100 I=I1,I2
30053         LISTL = LISTL+1
30054         IDBAM(LISTL) = IRBAM(I)
30055         IDPDG(LISTL) = IRPDG(I)
30056         RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
30057         RGAM(LISTL)  = gam_list(iabs(IDBAM(LISTL)))
30058         RWG(LISTL)   = RWGHT(I)
30059  100  CONTINUE
30060
30061 C  debug output
30062       IF(IDEB(85).GE.20) THEN
30063         WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
30064      &    IVAL1,IVAL2
30065         DO 200 I=1,LISTL
30066           WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
30067  200    CONTINUE
30068       ENDIF
30069
30070       END
30071
30072 CDECK  ID>, PHO_MASSAD
30073       SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30074      &                     PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30075 C***********************************************************************
30076 C
30077 C    fine-correction of low mass strings to mass of corresponding
30078 C    resonance or two particle threshold
30079 C
30080 C    input:     IFLMO         PDG ID of mother particle
30081 C               IFL1,2        requested parton flavours
30082 C                             (not used at the moment)
30083 C               PMASS         reference mass (mass of mother particle)
30084 C               XMCON         conjecture of mass
30085 C
30086 C    output:    XMOUT         output mass (adjusted input mass)
30087 C                             moved ot nearest mass possible
30088 C               IDPDG         PDG resonance ID
30089 C               IDcpc         CPC resonance ID
30090 C
30091 C**********************************************************************
30092       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30093       SAVE
30094
30095       PARAMETER ( DEPS   =  1.D-8 )
30096
30097 C  input/output channels
30098       INTEGER LI,LO
30099       COMMON /POINOU/ LI,LO
30100 C  event debugging information
30101       INTEGER NMAXD
30102       PARAMETER (NMAXD=100)
30103       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30104      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30105       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30106      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30107 C  model switches and parameters
30108       CHARACTER*8 MDLNA
30109       INTEGER ISWMDL,IPAMDL
30110       DOUBLE PRECISION PARMDL
30111       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30112 C  general particle data
30113       double precision xm_list,tau_list,gam_list,
30114      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30115      &  xm_bb82_list,xm_bb102_list
30116       integer          ich3_list,iba3_list,iq_list,
30117      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
30118       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30119      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
30120      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30121      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30122      &  ich3_list(300),iba3_list(300),iq_list(3,300),
30123      &  id_psm_list(6,6),id_vem_list(6,6),
30124      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
30125 C  particle decay data
30126       double precision wg_sec_list
30127       integer          idec_list,isec_list
30128       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30129      &  isec_list(3,500)
30130
30131       DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30132
30133       XMINP = XMCON
30134       IDPDG = 0
30135       IDcpc = 0
30136       XMOUT = XMINP
30137
30138 C  resonance treatment activated?
30139       IF(ISWMDL(23).EQ.0) RETURN
30140
30141       CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30142       IF(LISTL.LT.1) THEN
30143         IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30144      &    'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30145      &    IFLMO,IFL1,IFL2
30146         GOTO 50
30147       ENDIF
30148 C  mass small?
30149       PMASSL = (PMASS+0.15D0)**2
30150       XMINP2 = XMINP**2
30151 C  determine resonance probability
30152       DM2 = 1.1D0
30153       RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30154       IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30155 C  sample new resonance
30156         XWGSUM = 0.D0
30157         DO 100 I=1,LISTL
30158           XWG(I) = RWG(I)/RMA(I)**2
30159           XWGSUM = XWGSUM+XWG(I)
30160  100    CONTINUE
30161
30162         ITER = 0
30163  150    CONTINUE
30164         ITER = ITER+1
30165         IF(ITER.GE.5) THEN
30166           IDcpc = 0
30167           IDPDG = 0
30168           XMOUT = XMINP
30169           GOTO 50
30170         ENDIF
30171
30172         I = 0
30173         XI = XWGSUM*DT_RNDM(XMOUT)
30174  200    CONTINUE
30175           I = I+1
30176           XWGSUM = XWGSUM-XWG(I)
30177         IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30178         IDPDG = IRPDG(I)
30179         IDcpc = IRBAM(I)
30180         GARES = RGA(I)
30181         XMRES = RMA(I)
30182         XMRES2 = XMRES**2
30183 C  sample new mass (from Breit-Wigner cross section)
30184         ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30185         AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30186         XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30187         XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30188         XMOUT = SQRT(XMOUT)
30189
30190 C  check mass for decay
30191         AMDCY = 2.D0*XMRES
30192         ID = abs(IDcpc)
30193         DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30194           AMSUM = 0.D0
30195           DO 275 I=1,3
30196             IF(isec_list(I,IK).NE.0)
30197      &        AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30198  275      CONTINUE
30199           AMDCY = MIN(AMDCY,AMSUM)
30200  250    CONTINUE
30201         IF(AMDCY.GE.XMOUT) GOTO 150
30202
30203 C  debug output
30204         IF(IDEB(7).GE.10)
30205      &    WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30206      &    'PHO_MASSAD: ',
30207      &    'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30208      &    IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30209         RETURN
30210       ENDIF
30211
30212  50   CONTINUE
30213 C  debug output
30214       IF(IDEB(7).GE.15)
30215      &  WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30216      &    'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30217      &    IFLMO,IFL1,IFL2,XMCON,XMOUT
30218
30219       END
30220
30221 CDECK  ID>, PHO_PDF
30222       SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30223 C***************************************************************
30224 C
30225 C     call different PDF sets for different particle types
30226 C
30227 C     input:      NPAR     1     IGRP(1),ISET(1)
30228 C                          2     IGRP(2),ISET(2)
30229 C                 X        momentum fraction
30230 C                 SCALE2   squared scale (GeV**2)
30231 C                 P2VIR    particle virtuality (positive, GeV**2)
30232 C
30233 C     output      PD(-6:6) field containing the x*PDF fractions
30234 C
30235 C***************************************************************
30236       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30237       SAVE
30238
30239       DIMENSION PD(-6:6)
30240
30241 C  input/output channels
30242       INTEGER LI,LO
30243       COMMON /POINOU/ LI,LO
30244 C  currently activated parton density parametrizations
30245       CHARACTER*8 PDFNAM
30246       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30247       DOUBLE PRECISION PDFLAM,PDFQ2M
30248       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30249      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30250 C  event debugging information
30251       INTEGER NMAXD
30252       PARAMETER (NMAXD=100)
30253       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30254      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30255       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30256      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30257 C  model switches and parameters
30258       CHARACTER*8 MDLNA
30259       INTEGER ISWMDL,IPAMDL
30260       DOUBLE PRECISION PARMDL
30261       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30262
30263       DIMENSION PARAM(20),VALUE(20)
30264       CHARACTER*20 PARAM
30265
30266       REAL XR,P2R,Q2R,F2GM,XPDFGM
30267       DIMENSION XPDFGM(-6:6)
30268
30269 C  check of kinematic boundaries
30270       XI = X
30271       IF(X.GT.1.D0) THEN
30272         IF(IDEB(37).GE.0) THEN
30273           WRITE(LO,'(/,1X,A,E15.8/)')
30274      &      'PHO_PDF: x>1 (corrected to x=1)',X
30275           CALL PHO_PREVNT(-1)
30276         ENDIF
30277         XI = 0.99999999999D0
30278       ELSE IF(X.LE.0.D0) THEN
30279         IF(IDEB(37).GE.0) THEN
30280           WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30281           CALL PHO_PREVNT(-1)
30282         ENDIF
30283         XI = 0.0001D0
30284       ENDIF
30285
30286       DO 100 I=-6,6
30287         PD(I) = 0.D0
30288  100  CONTINUE
30289       IRET = 1
30290
30291       IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30292
30293 C  internal PDFs
30294
30295         IF(IEXT(NPAR).EQ.0) THEN
30296           IF(ITYPE(NPAR).EQ.1) THEN
30297 C  proton PDFs
30298             IF(IGRP(NPAR).EQ.5) THEN
30299               IF(ISET(NPAR).EQ.3) THEN
30300                 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30301                 UV = UDV-DV
30302                 UDB = 2.D0*UDB
30303                 DEL = 0.D0
30304                 IRET = 0
30305               ELSE IF(ISET(NPAR).EQ.4) THEN
30306                 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30307                 UV = UDV-DV
30308                 UDB = 2.D0*UDB
30309                 DEL = 0.D0
30310                 IRET = 0
30311               ELSE IF(ISET(NPAR).EQ.5) THEN
30312                 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30313 C  heavy quarks from GRV92-HO
30314                 AMU2  = 0.3
30315                 ALAM2 = 0.248 * 0.248
30316                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30317                 SC  =  0.820
30318                 ALC =   0.98
30319                 BEC =   0.0
30320                 AKC = -0.625 - 0.523 * S
30321                 AGC =   0.0
30322                 BC  =  1.896 + 1.616 * S
30323                 DC  =   4.12 + 0.683 * S
30324                 EC  =   4.36 + 1.328 * S
30325                 ESC =  0.677 + 0.679 * S
30326                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30327                 SBO =  1.297
30328                 ALB =   0.99
30329                 BEB =   0.0
30330                 AKB =   0.0  - 0.193 * S
30331                 AGB =   0.0
30332                 BBO =   0.0
30333                 DB  =  3.447 + 0.927 * S
30334                 EB  =   4.68 + 1.259 * S
30335                 ESB =  1.892 + 2.199 * S
30336                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30337                 IRET = 0
30338               ELSE IF(ISET(NPAR).EQ.6) THEN
30339                 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30340 C  heavy quarks from GRV92-LO
30341                 AMU2  = 0.25
30342                 ALAM2 = 0.232D0**2
30343                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30344                 SC  =  0.888
30345                 ALC =   1.01
30346                 BEC =   0.37
30347                 AKC =   0.0
30348                 AGC =   0.0
30349                 BC  =   4.24 - 0.804 * S
30350                 DC  =   3.46 + 1.076 * S
30351                 EC  =   4.61 + 1.490 * S
30352                 ESC =  2.555 + 1.961 * S
30353                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30354                 SBO =  1.351
30355                 ALB =   1.00
30356                 BEB =   0.51
30357                 AKB =   0.0
30358                 AGB =   0.0
30359                 BBO =  1.848
30360                 DB  =  2.929 + 1.396 * S
30361                 EB  =   4.71 + 1.514 * S
30362                 ESB =   4.02 + 1.239 * S
30363                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30364                 IRET = 0
30365               ELSE IF(ISET(NPAR).EQ.7) THEN
30366                 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30367 C  heavy quarks from GRV92-HO
30368                 AMU2  = 0.3
30369                 ALAM2 = 0.248 * 0.248
30370                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30371                 SC  =  0.820
30372                 ALC =   0.98
30373                 BEC =   0.0
30374                 AKC = -0.625 - 0.523 * S
30375                 AGC =   0.0
30376                 BC  =  1.896 + 1.616 * S
30377                 DC  =   4.12 + 0.683 * S
30378                 EC  =   4.36 + 1.328 * S
30379                 ESC =  0.677 + 0.679 * S
30380                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30381                 SBO =  1.297
30382                 ALB =   0.99
30383                 BEB =   0.0
30384                 AKB =   0.0  - 0.193 * S
30385                 AGB =   0.0
30386                 BBO =   0.0
30387                 DB  =  3.447 + 0.927 * S
30388                 EB  =   4.68 + 1.259 * S
30389                 ESB =  1.892 + 2.199 * S
30390                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30391                 IRET = 0
30392               ELSE IF(ISET(NPAR).EQ.8) THEN
30393                 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30394                 DEL = DS-US
30395                 UDB = DS+US
30396 C  heavy quarks from GRV92-LO
30397                 AMU2  = 0.25
30398                 ALAM2 = 0.232D0**2
30399                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30400                 SC  =  0.888
30401                 ALC =   1.01
30402                 BEC =   0.37
30403                 AKC =   0.0
30404                 AGC =   0.0
30405                 BC  =   4.24 - 0.804 * S
30406                 DC  =   3.46 + 1.076 * S
30407                 EC  =   4.61 + 1.490 * S
30408                 ESC =  2.555 + 1.961 * S
30409                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30410                 SBO =  1.351
30411                 ALB =   1.00
30412                 BEB =   0.51
30413                 AKB =   0.0
30414                 AGB =   0.0
30415                 BBO =  1.848
30416                 DB  =  2.929 + 1.396 * S
30417                 EB  =   4.71 + 1.514 * S
30418                 ESB =   4.02 + 1.239 * S
30419                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30420                 IRET = 0
30421               ELSE IF(ISET(NPAR).EQ.9) THEN
30422 *               CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30423                 DEL = DS-US
30424                 UDB = DS+US
30425 C  heavy quarks from GRV92-LO
30426                 AMU2  = 0.25
30427                 ALAM2 = 0.232D0**2
30428                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30429                 SC  =  0.888
30430                 ALC =   1.01
30431                 BEC =   0.37
30432                 AKC =   0.0
30433                 AGC =   0.0
30434                 BC  =   4.24 - 0.804 * S
30435                 DC  =   3.46 + 1.076 * S
30436                 EC  =   4.61 + 1.490 * S
30437                 ESC =  2.555 + 1.961 * S
30438                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30439                 SBO =  1.351
30440                 ALB =   1.00
30441                 BEB =   0.51
30442                 AKB =   0.0
30443                 AGB =   0.0
30444                 BBO =  1.848
30445                 DB  =  2.929 + 1.396 * S
30446                 EB  =   4.71 + 1.514 * S
30447                 ESB =   4.02 + 1.239 * S
30448                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30449                 IRET = 0
30450               ENDIF
30451               PD(-5) = BB
30452               PD(-4) = CB
30453               PD(-3) = SB
30454               PD(-2) = 0.5D0*(UDB-DEL)
30455               PD(-1) = 0.5D0*(UDB+DEL)
30456               PD(0)  = GL
30457               PD(1)  = DV+PD(-1)
30458               PD(2)  = UV+PD(-2)
30459               PD(3)  = PD(-3)
30460               PD(4)  = PD(-4)
30461               PD(5)  = PD(-5)
30462             ENDIF
30463           ELSE IF(ITYPE(NPAR).EQ.2) THEN
30464 C  pion PDFs (default for pi+)
30465             IF(IGRP(NPAR).EQ.5) THEN
30466               IF(ISET(NPAR).EQ.1) THEN
30467                 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30468                 IRET = 0
30469               ELSE IF(ISET(NPAR).EQ.2) THEN
30470                 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30471                 IRET = 0
30472               ENDIF
30473               PD(-5) = BB
30474               PD(-4) = CB
30475               PD(-3) = QB
30476               PD(-2) = QB
30477               PD(-1) = QB+VA
30478               PD(0)  = GL
30479               PD(1)  = QB
30480               PD(2)  = VA+QB
30481               PD(3)  = QB
30482               PD(4)  = CB
30483               PD(5)  = BB
30484             ENDIF
30485           ELSE IF(ITYPE(NPAR).EQ.3) THEN
30486 C  photon PDFs
30487             IF(IGRP(NPAR).EQ.5) THEN
30488               IF(ISET(NPAR).EQ.1) THEN
30489                 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30490                 IRET = 0
30491               ELSE IF(ISET(NPAR).EQ.2) THEN
30492                 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30493                 IRET = 0
30494               ELSE IF(ISET(NPAR).EQ.3) THEN
30495                 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30496                 IRET = 0
30497               ENDIF
30498 C  reweight with Drees-Godbole factor
30499               WGX = 1.D0
30500               IF(P2VIR.GT.0.001D0) THEN
30501                 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30502      &               /LOG(SCALE2/PARMDL(144))
30503                 WGX = MAX(WGX,0.D0)
30504               ENDIF
30505               PD(-5) = BB*WGX/137.D0
30506               PD(-4) = CB*WGX/137.D0
30507               PD(-3) = SB*WGX/137.D0
30508               PD(-2) = UB*WGX/137.D0
30509               PD(-1) = DB*WGX/137.D0
30510               PD(0)  = GL*WGX*WGX/137.D0
30511               PD(1)  = PD(-1)
30512               PD(2)  = PD(-2)
30513               PD(3)  = PD(-3)
30514               PD(4)  = PD(-4)
30515               PD(5)  = PD(-5)
30516             ELSE IF(IGRP(NPAR).EQ.8) THEN
30517               IF(ISET(NPAR).EQ.1) THEN
30518                 CALL PHO_PHGAL (XI,SCALE2,PD)
30519                 IRET = 0
30520               ENDIF
30521             ENDIF
30522           ELSE IF(ITYPE(NPAR).EQ.20) THEN
30523 C  Pomeron PDFs
30524             MODE = IGRP(NPAR)
30525             IF(MODE.EQ.1) THEN
30526               PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30527               IRET = 0
30528             ELSE IF(MODE.EQ.2) THEN
30529               PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30530               IRET = 0
30531             ELSE IF(MODE.EQ.3) THEN
30532               PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30533               IRET = 0
30534             ELSE IF(MODE.EQ.4) THEN
30535               CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30536               DO 105 I=-4,4
30537                 PD(I) = PD(I)*PARMDL(78)
30538  105          CONTINUE
30539               IRET = 0
30540             ENDIF
30541           ENDIF
30542
30543 C  external PDFs
30544
30545         ELSE IF(IEXT(NPAR).EQ.2) THEN
30546 C  PDFLIB call: new PDF numbering
30547           IF(NPAR.NE.NPAOLD) THEN
30548             PARAM(1) = 'NPTYPE'
30549             PARAM(2) = 'NGROUP'
30550             PARAM(3) = 'NSET'
30551             PARAM(4) = ' '
30552             VALUE(1) = ITYPE(NPAR)
30553             VALUE(2) = ABS(IGRP(NPAR))
30554             VALUE(3) = ISET(NPAR)
30555             CALL PDFSET(PARAM,VALUE)
30556           ENDIF
30557           IF(ITYPE(NPAR).EQ.3) THEN
30558             IP2 = 0
30559             CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30560      &                   PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30561           ELSE
30562             SCALE = SQRT(SCALE2)
30563             CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30564      &                   PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30565           ENDIF
30566           DO 115 I=3,6
30567             PD(I) = PD(-I)
30568  115      CONTINUE
30569           IF(ITYPE(NPAR).EQ.1) THEN
30570 C  proton valence quarks
30571             PD(1) = PD(1)+PD(-1)
30572             PD(2) = PD(2)+PD(-2)
30573           ELSE IF(ITYPE(NPAR).EQ.2) THEN
30574 C  pi+ valences
30575             DVAL = PD(1)
30576             PD(1) = PD(-1)
30577             PD(-1) = DVAL+PD(1)
30578             PD(2) = PD(2)+PD(-2)
30579           ELSE IF(ITYPE(NPAR).EQ.3) THEN
30580 C  photon conventions
30581             PD(1) = PD(-1)
30582             PD(2) = PD(-2)
30583           ENDIF
30584           IRET = 0
30585
30586         ELSE IF(IEXT(NPAR).EQ.3) THEN
30587 C  PHOLIB call: version 2.0
30588           CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30589           IF(IRET.LT.0) THEN
30590             WRITE(LO,'(/1X,A,I2)')
30591      &        'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30592             CALL PHO_ABORT
30593           ENDIF
30594           IRET = 0
30595
30596 C  photon PDFs depending on photon virtuality
30597
30598         ELSE IF(IEXT(NPAR).EQ.4) THEN
30599           IF(IGRP(NPAR).EQ.1) THEN
30600 C  Schuler/Sjostrand PDF (interface to single precision)
30601             XR = XI
30602             Q2R = SCALE2
30603             P2R = P2VIR
30604             IP2 = 0
30605             CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30606             DO 120 I=-6,6
30607               PD(I) = DBLE(XPDFGM(I))
30608  120        CONTINUE
30609             IRET = 0
30610           ELSE IF(IGRP(NPAR).EQ.5) THEN
30611 C  Gluck/Reya/Stratmann
30612             IF(ISET(NPAR).EQ.4) THEN
30613               CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30614               CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30615               IRET = 0
30616               PD(-5) = 0.D0
30617               PD(-4) = CB
30618               PD(-3) = SB/137.D0
30619               PD(-2) = UB/137.D0
30620               PD(-1) = DB/137.D0
30621               PD(0)  = GL/137.D0
30622               PD(1)  = PD(-1)
30623               PD(1)  = PD(-1)
30624               PD(2)  = PD(-2)
30625               PD(3)  = PD(-3)
30626               PD(4)  = PD(-4)
30627               PD(5)  = PD(-5)
30628             ENDIF
30629           ENDIF
30630         ENDIF
30631
30632 C  check for errors
30633
30634         IF(IRET.NE.0) THEN
30635           WRITE(LO,'(/1X,A,/10X,5I6)')
30636      &      'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30637      &      NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30638           CALL PHO_ABORT
30639         ENDIF
30640 C  error in NPAR
30641       ELSE
30642         WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30643         CALL PHO_ABORT
30644       ENDIF
30645       NPAOLD = NPAR
30646
30647 C  valence quark treatment
30648
30649       IF(ITYPE(NPAR).EQ.2) THEN
30650 C  meson conventions
30651         IF(IPARID(NPAR).EQ.111) THEN
30652 C  pi0 valence quarks
30653           PD(-1) = (PD(1)+PD(-1))/2.D0
30654           PD(1)  = PD(-1)
30655           PD(-2) = (PD(2)+PD(-2))/2.D0
30656           PD(2)  = PD(-2)
30657         ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30658 C  K+/-
30659           VALS = PD(-1)-PD(1)
30660           PD(-1) = PD(1)
30661           PD(-3) = PD(-3)+VALS
30662         ELSE IF(    (IPARID(NPAR).EQ.311)
30663      &          .OR.(IPARID(NPAR).EQ.310)
30664      &          .OR.(IPARID(NPAR).EQ.130)) THEN
30665 C  neutral kaons
30666           VALS = PD(-1)-PD(1)
30667           VALU = PD(2)-PD(-2)
30668           PD(-1) = PD(1)
30669           PD(2) = PD(-2)
30670           PD(2)  = PD(2)+VALU/2.D0
30671           PD(-2) = PD(-2)+VALU/2.D0
30672           PD(3)  = PD(3)+VALS/2.D0
30673           PD(-3) = PD(-3)+VALS/2.D0
30674         ENDIF
30675       ELSE IF(ITYPE(NPAR).EQ.1) THEN
30676 C  nucleon conventions
30677         IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30678 C  neutron valence quarks
30679           DUM = PD(1)
30680           PD(1) = PD(2)
30681           PD(2) = DUM
30682         ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30683 C  (anti-)sigma+
30684           VALS = PD(1)-PD(-1)
30685           PD(1) = PD(-1)
30686           PD(3) = PD(3)+VALS
30687         ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30688 C  (anti-)sigma-
30689           VALS = PD(1)-PD(-1)
30690           VALD = PD(2)-PD(-2)
30691           PD(1) = PD(-1)
30692           PD(2) = PD(-2)
30693           PD(1) = PD(1)+VALD
30694           PD(3) = PD(3)+VALS
30695         ELSE IF(    (ABS(IPARID(NPAR)).EQ.3122)
30696      &          .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30697 C  (anti-)sigma0 and (anti-)lambda
30698           VALS = PD(1)-PD(-1)
30699           VALD = (PD(2)-PD(-2))/2.D0
30700           PD(1) = PD(-1)
30701           PD(2) = PD(-2)
30702           PD(1) = PD(1)+VALD
30703           PD(2) = PD(2)+VALD
30704           PD(3) = PD(3)+VALS
30705         ENDIF
30706       ENDIF
30707
30708 C  antiparticle
30709       IF(IPARID(NPAR).LT.0) THEN
30710         DO 190 I=1,4
30711           DUM=PD(I)
30712           PD(I)=PD(-I)
30713           PD(-I)=DUM
30714  190    CONTINUE
30715       ENDIF
30716
30717 C  optionally remove valence quarks
30718       IF(IPAVA(NPAR).EQ.0) THEN
30719         DO 200 I=1,4
30720           PD(I) = MIN(PD(-I),PD(I))
30721           PD(-I) = PD(I)
30722  200    CONTINUE
30723       ENDIF
30724
30725 C  debug information
30726       IF(IDEB(37).GE.30) WRITE(LO,
30727      &  '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30728      &  'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30729      &  NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30730      &  'PD(0)     ',PD(0),'PD(1..6)  ',(PD(I),I=1,6)
30731
30732       END
30733
30734 CDECK  ID>, PHO_QPMPDF
30735       SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30736 C***************************************************************
30737 C
30738 C     contribution to photon PDF from box graph
30739 C     (Bethe-Heitler process)
30740 C
30741 C     input:      IQ       quark flavour
30742 C                 SCALE2   scale (GeV**2, positive)
30743 C                 PTREF    reference scale (GeV, positive)
30744 C                 X        parton momentum fraction
30745 C                 PVIRT    photon virtuality (GeV**2, positive)
30746 C                 FXP      x*f(x,Q**2), x times parton density
30747 C
30748 C***************************************************************
30749       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30750       SAVE
30751
30752 C  input/output channels
30753       INTEGER LI,LO
30754       COMMON /POINOU/ LI,LO
30755 C  event debugging information
30756       INTEGER NMAXD
30757       PARAMETER (NMAXD=100)
30758       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30759      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30760       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30761      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30762 C  internal rejection counters
30763       INTEGER NMXJ
30764       PARAMETER (NMXJ=60)
30765       CHARACTER*10 REJTIT
30766       INTEGER IFAIL
30767       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30768 C  some constants
30769       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30770       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30771      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30772
30773       DIMENSION QM(6)
30774       DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
30775
30776       FXP = 0.D0
30777       I = ABS(IQ)
30778 C
30779 *     QM2 = MAX(QM(I),PTREF)**2
30780 *     QM2 = MAX(QM2,PVIRT)
30781 *     BBE = (1.D0-X)*SCALE2
30782 *     IF(BBE.LE.0.D0) THEN
30783 *       IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30784 *    &    'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
30785 *    &    PVIRT,QM(I)
30786 *     ENDIF
30787 *     FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
30788 *    &  *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
30789 C  Bethe-Heitler process approximation for 2*x*p2/q2 << 1
30790       QM2 = MAX(QM(I),PTREF)**2
30791       W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
30792       IF(W2.GT.4.D0*QM2) THEN
30793         BE = SQRT(1.D0-4.D0*QM2/W2)
30794         BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30795         BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30796 *       FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
30797         FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
30798      &         +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
30799      &         -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
30800      &         +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
30801      &         -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
30802       ELSE
30803         IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30804      &    'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
30805      &    PVIRT,QM(I)
30806       ENDIF
30807 C  debug output
30808       IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
30809      &  'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
30810       END
30811
30812 CDECK  ID>, PHO_SETPDF
30813       SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
30814 C***************************************************************
30815 C
30816 C     assigns  PDF numbers to particles
30817 C
30818 C     input:      IDPDG    PDG number of particle
30819 C                 ITYP     particle type
30820 C                 IPAR     PDF paramertization
30821 C                 ISET     number of set
30822 C                 IEXT     library number for PDF calculation
30823 C                 IPAVAL   (only output)
30824 C                          1 PDF with valence quarks
30825 C                          0 PDF without valence quarks
30826 C                 MODE     -1   add entry to table
30827 C                           1   read from table
30828 C                           2   output of table
30829 C
30830 C***************************************************************
30831       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30832       SAVE
30833
30834 C  input/output channels
30835       INTEGER LI,LO
30836       COMMON /POINOU/ LI,LO
30837 C  event debugging information
30838       INTEGER NMAXD
30839       PARAMETER (NMAXD=100)
30840       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30841      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30842       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30843      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30844 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
30845       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30846       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30847       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30848      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30849
30850       DIMENSION IPDFS(5,50)
30851       DATA IENTRY / 0 /
30852
30853       IF(MODE.EQ.1) THEN
30854         I = 1
30855         IF(IDPDG.EQ.81) THEN
30856           IDCMP = IDEQP(1)
30857           IPAVAL = IHFLS(1)
30858         ELSE IF(IDPDG.EQ.82) THEN
30859           IDCMP = IDEQP(2)
30860           IPAVAL = IHFLS(2)
30861         ELSE
30862           IDCMP = IDPDG
30863           IPAVAL = 1
30864         ENDIF
30865 200     CONTINUE
30866           IF(IDCMP.EQ.IPDFS(1,I)) THEN
30867             ITYP = IPDFS(2,I)
30868             IPAR = IPDFS(3,I)
30869             ISET = IPDFS(4,I)
30870             IEXT = IPDFS(5,I)
30871             IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
30872      &        'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
30873             RETURN
30874           ENDIF
30875           I = I+1
30876           IF(I.GT.IENTRY) THEN
30877             WRITE(LO,'(/1X,A,I7)')
30878      &        'PHO_SETPDF: no PDF assigned to ',IDCMP
30879             CALL PHO_ABORT
30880           ENDIF
30881         GOTO 200
30882       ELSE IF(MODE.EQ.-1) THEN
30883         DO 50 I=1,IENTRY
30884           IF(IDPDG.EQ.IPDFS(1,I)) THEN
30885             WRITE(LO,'(/1X,A,5I6)')
30886      &        'PHO_SETPDF: overwrite old particle PDF',
30887      &        IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30888             GOTO 100
30889           ENDIF
30890  50     CONTINUE
30891         I = IENTRY+1
30892         IF(I.GT.50) THEN
30893           WRITE(LO,'(/1X,A,/1x,6I6)')
30894      &      'PHO_SETPDF:ERROR: no space left in IPDFS:',
30895      &      I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30896           STOP
30897         ENDIF
30898         IENTRY = I
30899  100    CONTINUE
30900         IPDFS(1,I) = IDPDG
30901         IF(IDPDG.EQ.990) THEN
30902           ITYP1 = 20
30903         ELSE IF(IDPDG.EQ.22) THEN
30904           ITYP1 = 3
30905         ELSE IF(ABS(IDPDG).LT.1000) THEN
30906           ITYP1 = 2
30907         ELSE
30908           ITYP1 = 1
30909         ENDIF
30910         IPDFS(2,I) = ITYP1
30911         IPDFS(3,I) = IPAR
30912         IPDFS(4,I) = ISET
30913         IPDFS(5,I) = IEXT
30914       ELSE IF(MODE.EQ.-2) THEN
30915         WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
30916         DO 150 I=1,IENTRY
30917           WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,'  particle:',IPDFS(1,I),
30918      &      '   PDF-set  ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30919  150    CONTINUE
30920       ELSE
30921         WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
30922       ENDIF
30923       END
30924
30925 CDECK  ID>, PHO_GETPDF
30926       SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
30927 C***************************************************************
30928 C
30929 C     get PDF information
30930 C
30931 C     input:      NPAR     1  first PDF in /POPPDF/
30932 C                          2  second PDF in /POPPDF/
30933 C
30934 C     output:     PDFNA    name of PDf parametrization
30935 C                 ALA      QCD LAMBDA (4 flavours, in GeV)
30936 C                 Q2MI     minimal Q2
30937 C                 Q2MA     maximal Q2
30938 C                 XMI      minimal X
30939 C                 XMA      maximal X
30940 C
30941 C***************************************************************
30942       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30943       SAVE
30944
30945       CHARACTER*8 PDFNA
30946
30947 C  input/output channels
30948       INTEGER LI,LO
30949       COMMON /POINOU/ LI,LO
30950
30951 C  PHOLIB 4.15 common
30952       COMMON /W50512/ QCDL4,QCDL5
30953       COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
30954
30955 C  PHOPDF version 2.0 common
30956       PARAMETER (MAXS=6,MAXP=10)
30957       CHARACTER*4 CHPAR
30958       COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
30959      & NSET(MAXP,2),NFL(MAXP)
30960       COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
30961
30962 C  currently activated parton density parametrizations
30963       CHARACTER*8 PDFNAM
30964       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30965       DOUBLE PRECISION PDFLAM,PDFQ2M
30966       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30967      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30968
30969       DIMENSION PARAM(20),VALUE(20)
30970       CHARACTER*20 PARAM
30971
30972       IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
30973         WRITE(LO,'(/1X,A,I6)')
30974      &    'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
30975         CALL PHO_ABORT
30976       ENDIF
30977       ALA = 0.D0
30978
30979       IF(IEXT(NPAR).EQ.0) THEN
30980
30981 C  internal parametrizations
30982
30983         IF(ITYPE(NPAR).EQ.1) THEN
30984 C  proton PDFs
30985           IF(IGRP(NPAR).EQ.5) THEN
30986             IF(ISET(NPAR).EQ.3) THEN
30987               ALA    = 0.2D0
30988               Q2MI   = 0.3D0
30989               PDFNA  = 'GRV92 HO'
30990             ELSE IF(ISET(NPAR).EQ.4) THEN
30991               ALA    = 0.2D0
30992               Q2MI   = 0.25D0
30993               PDFNA  = 'GRV92 LO'
30994             ELSE IF(ISET(NPAR).EQ.5) THEN
30995               ALA    = 0.2D0
30996               Q2MI   = 0.4D0
30997               PDFNA  = 'GRV94 HO'
30998             ELSE IF(ISET(NPAR).EQ.6) THEN
30999               ALA    = 0.2D0
31000               Q2MI   = 0.4D0
31001               PDFNA  = 'GRV94 LO'
31002             ELSE IF(ISET(NPAR).EQ.7) THEN
31003               ALA    = 0.2D0
31004               Q2MI   = 0.4D0
31005               PDFNA  = 'GRV94 DI'
31006             ELSE IF(ISET(NPAR).EQ.8) THEN
31007               ALA    = 0.175D0
31008               Q2MI   = 0.8D0
31009               PDFNA  = 'GRV98 LO'
31010             ELSE IF(ISET(NPAR).EQ.9) THEN
31011               ALA    = 0.175D0
31012               Q2MI   = 0.8D0
31013               PDFNA  = 'GRV98 SC'
31014             ENDIF
31015           ENDIF
31016         ELSE IF(ITYPE(NPAR).EQ.2) THEN
31017 C  pion PDFs
31018           IF(IGRP(NPAR).EQ.5) THEN
31019             IF(ISET(NPAR).EQ.1) THEN
31020               ALA    = 0.2D0
31021               Q2MI   = 0.3D0
31022               PDFNA  = 'GRV-P HO'
31023             ELSE IF(ISET(NPAR).EQ.2) THEN
31024               ALA    = 0.2D0
31025               Q2MI   = 0.25D0
31026               PDFNA  = 'GRV-P LO'
31027             ENDIF
31028           ENDIF
31029         ELSE IF(ITYPE(NPAR).EQ.3) THEN
31030 C  photon PDFs
31031           IF(IGRP(NPAR).EQ.5) THEN
31032             IF(ISET(NPAR).EQ.1) THEN
31033               ALA    = 0.2D0
31034               Q2MI   = 0.3D0
31035               PDFNA  = 'GRV-G LH'
31036             ELSE IF(ISET(NPAR).EQ.2) THEN
31037               ALA    = 0.2D0
31038               Q2MI   = 0.3D0
31039               PDFNA  = 'GRV-G HO'
31040             ELSE IF(ISET(NPAR).EQ.3) THEN
31041               ALA    = 0.2D0
31042               Q2MI   = 0.25D0
31043               PDFNA  = 'GRV-G LO'
31044             ENDIF
31045           ELSE IF(IGRP(NPAR).EQ.8) THEN
31046             IF(ISET(NPAR).EQ.1) THEN
31047               ALA    = 0.2D0
31048               Q2MI   = 4.D0
31049               PDFNA  = 'AGL-G LO'
31050             ENDIF
31051           ENDIF
31052         ELSE IF(ITYPE(NPAR).EQ.20) THEN
31053 C  pomeron PDFs
31054           IF(IGRP(NPAR).EQ.4) THEN
31055             CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
31056           ELSE
31057             ALA    = 0.3D0
31058             Q2MI   = 2.D0
31059             PDFNA  = 'POM-PDF1'
31060           ENDIF
31061         ENDIF
31062
31063 C  external parametrizations
31064
31065       ELSE IF(IEXT(NPAR).EQ.1) THEN
31066 C  PDFLIB call: old numbering
31067         PARAM(1) = 'MODE'
31068         PARAM(2) = ' '
31069         VALUE(1) = IGRP(NPAR)
31070         CALL PDFSET(PARAM,VALUE)
31071         Q2MI = Q2MIN
31072         Q2MA = Q2MAX
31073         XMI  = XMIN
31074         XMA  = XMAX
31075         ALA  = QCDL4
31076         PDFNA = 'PDFLIB1'
31077       ELSE IF(IEXT(NPAR).EQ.2) THEN
31078 C  PDFLIB call: new numbering
31079         PARAM(1) = 'NPTYPE'
31080         PARAM(2) = 'NGROUP'
31081         PARAM(3) = 'NSET'
31082         PARAM(4) = ' '
31083         VALUE(1) = ITYPE(NPAR)
31084         VALUE(2) = IGRP(NPAR)
31085         VALUE(3) = ISET(NPAR)
31086         CALL PDFSET(PARAM,VALUE)
31087         Q2MI = Q2MIN
31088         Q2MA = Q2MAX
31089         XMI  = XMIN
31090         XMA  = XMAX
31091         ALA  = QCDL4
31092         PDFNA = 'PDFLIB2'
31093       ELSE IF(IEXT(NPAR).EQ.3) THEN
31094 C  PHOLIB interface
31095         ALA  = ALM(IGRP(NPAR),ISET(NPAR))
31096         Q2MI = 2.D0
31097         PDFNA = CHPAR(IGRP(NPAR))
31098
31099 C  some special internal parametrizations
31100
31101       ELSE IF(IEXT(NPAR).EQ.4) THEN
31102 C  photon PDFs depending on virtualities
31103         IF(IGRP(NPAR).EQ.1) THEN
31104 C  Schuler/Sjostrand parametrization
31105           ALA = 0.2D0
31106           IF(ISET(NPAR).EQ.1) THEN
31107             Q2MI = 0.2D0
31108             PDFNA = 'SaS-1D  '
31109           ELSE IF(ISET(NPAR).EQ.2) THEN
31110             Q2MI = 0.2D0
31111             PDFNA = 'SaS-1M  '
31112           ELSE IF(ISET(NPAR).EQ.3) THEN
31113             Q2MI = 2.D0
31114             PDFNA = 'SaS-2D  '
31115           ELSE IF(ISET(NPAR).EQ.4) THEN
31116             Q2MI = 2.D0
31117             PDFNA = 'SaS-2M  '
31118           ENDIF
31119         ELSE IF(IGRP(NPAR).EQ.5) THEN
31120 C  Gluck/Reya/Stratmann parametrization
31121           IF(ISET(NPAR).EQ.4) THEN
31122             ALA = 0.2D0
31123             Q2MI = 0.6D0
31124             PDFNA = 'GRS-G LO'
31125           ENDIF
31126         ENDIF
31127       ELSE IF(IEXT(NPAR).EQ.5) THEN
31128 C  Schuler/Sjostrand anomalous only
31129         ALA   = 0.2D0
31130         Q2MI  = 0.2D0
31131         PDFNA = 'SaS anom'
31132       ENDIF
31133       IF(ALA.LT.0.01D0) THEN
31134         WRITE(LO,'(/1X,2A,/10X,5I6)')
31135      &    'PHO_GETPDF:ERROR: ',
31136      &    'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31137      &    NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31138         CALL PHO_ABORT
31139       ENDIF
31140
31141       END
31142
31143 CDECK  ID>, PHO_ACTPDF
31144       SUBROUTINE PHO_ACTPDF(IDPDG,K)
31145 C***************************************************************
31146 C
31147 C     activate PDF for QCD calculations
31148 C
31149 C     input:      IDPDG    PDG particle number
31150 C                 K        1  first PDF in /POPPDF/
31151 C                          2  second PDF in /POPPDF/
31152 C                         -2  write current settings
31153 C
31154 C     output:     /POPPDF/
31155 C
31156 C***************************************************************
31157       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31158       SAVE
31159
31160 C  input/output channels
31161       INTEGER LI,LO
31162       COMMON /POINOU/ LI,LO
31163 C  event debugging information
31164       INTEGER NMAXD
31165       PARAMETER (NMAXD=100)
31166       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31167      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31168       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31169      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31170 C  currently activated parton density parametrizations
31171       CHARACTER*8 PDFNAM
31172       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31173       DOUBLE PRECISION PDFLAM,PDFQ2M
31174       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31175      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31176
31177       IF(K.GT.0) THEN
31178
31179 C  read PDF from table
31180         CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31181      &                 IPAVA(K),1)
31182         IPARID(K) = IDPDG
31183 C  get PDF parameters
31184         CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31185 C  initialize alpha_s calculation
31186         alam2 = PDFLAM(K)*PDFLAM(K)
31187         DUMMY = PHO_ALPHAS(alam2,-K)
31188
31189         IF(IDEB(2).GE.20) THEN
31190           WRITE(LO,'(1X,A)')
31191      &      'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31192           WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31193      &      PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31194      &      IEXT(K),IPARID(K)
31195         ENDIF
31196         NPAOLD = K
31197
31198       ELSE IF(K.EQ.-2) THEN
31199
31200 C  write table of current PDFs
31201         WRITE(LO,'(1X,A)')
31202      &    'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31203         WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31204      &    PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31205      &    IPARID(1)
31206         WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31207      &    PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31208      &    IPARID(2)
31209
31210       ELSE
31211
31212         WRITE(LO,'(/1X,A,2I4)')
31213      &    'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31214         CALL PHO_ABORT
31215
31216       ENDIF
31217
31218       END
31219
31220 CDECK  ID>, PHO_PDFTST
31221       SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31222 C*********************************************************************
31223 C
31224 C     structure function test utility
31225 C
31226 C     input:    IDPDG    PDG ID of particle
31227 C               SCALE2   squared scale (GeV**2)
31228 C               P2MASS   particle virtuality (pos, GeV**2)
31229 C
31230 C     output:   tables of PDF, sum rule checking, table of F2
31231 C
31232 C*********************************************************************
31233       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31234       SAVE
31235
31236 C  input/output channels
31237       INTEGER LI,LO
31238       COMMON /POINOU/ LI,LO
31239 C  currently activated parton density parametrizations
31240       CHARACTER*8 PDFNAM
31241       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31242       DOUBLE PRECISION PDFLAM,PDFQ2M
31243       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31244      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31245 C  some constants
31246       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31247       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31248      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31249
31250       DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31251       CHARACTER*8 PDFNA
31252
31253       CALL PHO_ACTPDF(IDPDG,1)
31254       CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31255
31256       WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31257       WRITE(LO,'(A)') ' ======================================='
31258
31259       WRITE(LO,'(/,A,3I10)')
31260      &  ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31261       WRITE(LO,'(A,A)')     ' corresponds to ',PDFNA
31262       WRITE(LO,'(A,E12.3)') '  used squared scale (GeV**2):',SCALE2
31263       WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31264       WRITE(LO,'(/1X,A)') 'x times parton densities'
31265       WRITE(LO,'(1X,A)') '    X         PD(-4 - 4)'
31266       WRITE(LO,'(1X,A)')
31267      &   ' ============================================================'
31268
31269 C  logarithmic loop over x values
31270 C  upper bound
31271       XUPPER=0.9999D0
31272 C  lower bound
31273       XLOWER=1.D-4
31274 C  number of steps
31275       NSTEP=50
31276
31277       XFIRST=LOG(XLOWER)
31278       XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31279       DO 100 I=1,NSTEP
31280         X=EXP(XFIRST)
31281         XCONTR=X
31282         CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31283         IF(X.NE.XCONTR) THEN
31284           WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31285         ENDIF
31286         WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31287         XFIRST=XFIRST+XDELTA
31288  100  CONTINUE
31289
31290       IF(IDPDG.EQ.22) THEN
31291         WRITE(LO,'(/1X,A)')
31292      &   'comparison PDF to contribution due to box diagram'
31293         WRITE(LO,'(1X,A)') '    X   PD(1),PB(1), .... ,PD(4),PB(4)'
31294         WRITE(LO,'(1X,A)')
31295      &   ' ============================================================'
31296         XFIRST=LOG(XLOWER)
31297         XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31298         DO 110 I=1,NSTEP
31299           X=EXP(XFIRST)
31300           CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31301           DO 120 K=1,4
31302             CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31303  120      CONTINUE
31304           WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31305           XFIRST=XFIRST+XDELTA
31306  110    CONTINUE
31307       ENDIF
31308
31309 C  check momentum sum rule
31310
31311       WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31312       DO 199 I=-6,6
31313         PDSUM(I) = 0.D0
31314         PDAVE(I) = 0.D0
31315  199  CONTINUE
31316       ITER=5000
31317       DO 200 I=1,ITER
31318         XX=DBLE(I)/DBLE(ITER)
31319         IF(XX.EQ.1.D0) XX = 0.999999D0
31320         CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31321         DO 202 K=-6,6
31322           PDSUM(K) = PDSUM(K)+PD(K)/XX
31323           PDAVE(K) = PDAVE(K)+PD(K)
31324  202    CONTINUE
31325  200  CONTINUE
31326       WRITE(LO,'(1X,A)')
31327      &  'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31328       XSUM = 0.D0
31329       DO 204 I=-6,6
31330         PDSUM(I) = PDSUM(I)/DBLE(ITER)
31331         PDAVE(I) = PDAVE(I)/DBLE(ITER)
31332         XSUM = XSUM+PDAVE(I)
31333         WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31334  204  CONTINUE
31335       WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31336       DO 205 I=1,6
31337         WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31338  205  CONTINUE
31339       WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31340       WRITE(LO,'(A/)') ' ============================================='
31341
31342 C  table of F2
31343
31344       WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31345      &  'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31346      &  '-----------------------------------------------------'
31347       ITER=100
31348       DO 300 I=1,ITER
31349         XX=DBLE(I)/DBLE(ITER)
31350         IF(XX.EQ.1.D0) XX = 0.9999D0
31351         CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31352         F2 = 0.D0
31353         DO 302 K=-6,6
31354           IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31355  302    CONTINUE
31356         WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31357  300  CONTINUE
31358       WRITE(LO,'(A/)') ' ============================================='
31359       END
31360
31361 CDECK  ID>, PHO_REGPAR
31362       SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31363      &                  IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31364 C**********************************************************************
31365 C
31366 C     registration of particle in /POEVT1/ and /POEVT2/
31367 C
31368 C     input:    ISTH             status code of particle
31369 C                                 -2     initial parton hard scattering
31370 C                                 -1     parton
31371 C                                  0     string
31372 C                                  1     visible particle (no color)
31373 C                                  2     decayed particle
31374 C               IDPDG            PDG particle ID code
31375 C               IDBAM            CPC particle ID code
31376 C               JM1,JM2          first and second mother index
31377 C               P1..P4           four momentum
31378 C               IPHIS1           extended history information
31379 C                                  IPHIS1<100: JM1 from particle 1
31380 C                                  IPHIS1>100: JM1 from particle 2
31381 C                                  1    valence quark
31382 C                                  2    valence diquark
31383 C                                  3    sea quark
31384 C                                  4    sea diquark
31385 C                                  (neg. for antipartons)
31386 C               IPHIS2           extended history information
31387 C                                  positive: JM2 from particle 1
31388 C                                  negative: JM2 from particle 2
31389 C                                  (see IPHIS1)
31390 C               IC1,IC2          color labels for partons
31391 C               IMODE            1  register given parton
31392 C                                0  reset /POEVT1/ and /POEVT2/
31393 C                                2  return data of entry IPOS
31394 C
31395 C               IPOS             position of particle in /POEVT1/
31396 C
31397 C**********************************************************************
31398       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31399       SAVE
31400
31401       PARAMETER (DEPS = 1.D-20)
31402
31403 C  input/output channels
31404       INTEGER LI,LO
31405       COMMON /POINOU/ LI,LO
31406 C  event debugging information
31407       INTEGER NMAXD
31408       PARAMETER (NMAXD=100)
31409       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31410      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31411       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31412      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31413
31414 C  standard particle data interface
31415       INTEGER NMXHEP
31416
31417       PARAMETER (NMXHEP=4000)
31418
31419       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31420       DOUBLE PRECISION PHEP,VHEP
31421       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31422      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31423      &                VHEP(4,NMXHEP)
31424 C  extension to standard particle data interface (PHOJET specific)
31425       INTEGER IMPART,IPHIST,ICOLOR
31426       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31427
31428       IF(IMODE.EQ.1) THEN
31429         IF(IDEB(76).GE.26) THEN
31430           WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31431      &      'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31432      &      ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31433           WRITE(LO,'(1X,A,/2X,6I6)')
31434      &      'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31435      &      IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31436         ENDIF
31437         IF(NHEP.EQ.NMXHEP) THEN
31438           WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31439      &      'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31440           CALL PHO_ABORT
31441         ENDIF
31442         NHEP = NHEP+1
31443         IDBAMI = IDBAM
31444         IDPDGI = IDPDG
31445         IF(ABS(ISTH).LE.2) THEN
31446           IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31447             IDPDGI = ipho_id2pdg(IDBAM)
31448           ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31449             IDBAMI = ipho_pdg2id(IDPDG)
31450           ENDIF
31451         ENDIF
31452 C  standard data
31453         ISTHEP(NHEP) = ISTH
31454         IDHEP(NHEP)  = IDPDGI
31455         JMOHEP(1,NHEP) = JM1
31456         JMOHEP(2,NHEP) = JM2
31457 C  update of mother-daugther relations
31458         IF(ABS(ISTH).LE.1) THEN
31459           IF(JM1.GT.0) THEN
31460             IF(JDAHEP(1,JM1).EQ.0) THEN
31461               JDAHEP(1,JM1) = NHEP
31462               ISTHEP(JM1) = 2
31463             ENDIF
31464             JDAHEP(2,JM1) = NHEP
31465           ENDIF
31466           IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31467             IF(JDAHEP(1,JM2).EQ.0) THEN
31468               JDAHEP(1,JM2) = NHEP
31469               ISTHEP(JM2) = 2
31470             ENDIF
31471             JDAHEP(2,JM2) = NHEP
31472           ELSE IF(JM2.LT.0) THEN
31473             DO 100 II=JM1+1,-JM2
31474               IF(JDAHEP(1,II).EQ.0) THEN
31475                 JDAHEP(1,II) = NHEP
31476                 ISTHEP(II) = 2
31477               ENDIF
31478               JDAHEP(2,II) = NHEP
31479 100         CONTINUE
31480           ENDIF
31481         ENDIF
31482         PHEP(1,NHEP) = P1
31483         PHEP(2,NHEP) = P2
31484         PHEP(3,NHEP) = P3
31485         PHEP(4,NHEP) = P4
31486         IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31487           TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31488           PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31489         ELSE
31490           PHEP(5,NHEP) = 0.D0
31491         ENDIF
31492         JDAHEP(1,NHEP) = 0
31493         JDAHEP(2,NHEP) = 0
31494 C  extended information
31495         IMPART(NHEP) = IDBAMI
31496 C  extended history information
31497         IPHIST(1,NHEP) = IPHIS1
31498         IPHIST(2,NHEP) = IPHIS2
31499 C  charge/baryon number or color labels
31500         IF(ISTH.EQ.1) THEN
31501           ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31502           ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31503         ELSE
31504           ICOLOR(1,NHEP) = IC1
31505           ICOLOR(2,NHEP) = IC2
31506         ENDIF
31507
31508         IPOS = NHEP
31509         IF(IDEB(76).GE.26) THEN
31510           WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31511      &      'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31512      &      IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31513      &      PHEP(5,NHEP),IPOS
31514         ENDIF
31515
31516       ELSE IF(IMODE.EQ.0) THEN
31517         NHEP   = 0
31518       ELSE IF(IMODE.EQ.2) THEN
31519         IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31520           WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31521      &      'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31522           RETURN
31523         ENDIF
31524         ISTH  = ISTHEP(IPOS)
31525         IDPDG = IDHEP(IPOS)
31526         IDBAM = IMPART(IPOS)
31527         JM1   = JMOHEP(1,IPOS)
31528         JM2   = JMOHEP(2,IPOS)
31529         P1    = PHEP(1,IPOS)
31530         P2    = PHEP(2,IPOS)
31531         P3    = PHEP(3,IPOS)
31532         P4    = PHEP(4,IPOS)
31533         IPHIS1= IPHIST(1,IPOS)
31534         IPHIS2= IPHIST(2,IPOS)
31535         IC1   = ICOLOR(1,IPOS)
31536         IC2   = ICOLOR(2,IPOS)
31537       ELSE
31538         WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31539       ENDIF
31540       END
31541
31542 CDECK  ID>, IPHO_CNV1
31543       INTEGER FUNCTION IPHO_CNV1(IPART)
31544 C*********************************************************************
31545 C
31546 C     conversion of quark numbering scheme to PARTICLE DATA GROUP
31547 C                                             convention
31548 C
31549 C     input:   old internal particle code of hard scattering
31550 C                    0   gluon
31551 C                    1   d
31552 C                    2   u
31553 C                    3   s
31554 C                    4   c
31555 C     valence quarks changed to standard numbering
31556 C
31557 C     output:  standard particle codes
31558 C
31559 C*********************************************************************
31560       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31561       SAVE
31562 C
31563       II = ABS(IPART)
31564 C  change gluon number
31565       IF(II.EQ.0) THEN
31566         IPHO_CNV1 = 21
31567 C  change valence quark
31568       ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31569         IPHO_CNV1 = SIGN(II-6,IPART)
31570       ELSE
31571         IPHO_CNV1 = IPART
31572       ENDIF
31573       END
31574
31575 CDECK  ID>, PHO_HACODE
31576       SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31577 C*********************************************************************
31578 C
31579 C     determination of hadron index from quarks
31580 C
31581 C     input:   ID1,ID2   parton code according to PDG conventions
31582 C
31583 C     output:  IDcpc1,2  CPC particle codes
31584 C
31585 C*********************************************************************
31586
31587       IMPLICIT NONE
31588
31589       SAVE
31590
31591       integer ID1,ID2,IDcpc1,IDcpc2
31592
31593 C  input/output channels
31594       INTEGER LI,LO
31595       COMMON /POINOU/ LI,LO
31596 C  event debugging information
31597       INTEGER NMAXD
31598       PARAMETER (NMAXD=100)
31599       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31600      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31601       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31602      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31603 C  general particle data
31604       double precision xm_list,tau_list,gam_list,
31605      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31606      &  xm_bb82_list,xm_bb102_list
31607       integer          ich3_list,iba3_list,iq_list,
31608      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
31609       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31610      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
31611      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31612      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31613      &  ich3_list(300),iba3_list(300),iq_list(3,300),
31614      &  id_psm_list(6,6),id_vem_list(6,6),
31615      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
31616
31617 C  local variables
31618       integer ii,jj,kk,i1,i2
31619
31620       IDcpc1 = 0
31621       IDcpc2 = 0
31622
31623       if(ID1*ID2.lt.0) then
31624 C  meson
31625         if(ID1.gt.0) then
31626           ii = ID1
31627           jj = -ID2
31628         else
31629           ii = ID2
31630           jj = -ID1
31631         endif
31632         IDcpc1 = ID_psm_list(ii,jj)
31633         IDcpc2 = ID_vem_list(ii,jj)
31634
31635       else
31636 C  baryon
31637         i1 = abs(ID1)
31638         i2 = abs(ID2)
31639         if(i1.gt.6) then
31640           ii = i1/1000
31641           jj = (i1-ii*1000)/100
31642           kk = i2
31643         else
31644           ii = i1
31645           jj = i2/1000
31646           kk = (i2-jj*1000)/100
31647         endif
31648         IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31649         IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31650
31651       endif
31652
31653       END
31654
31655 CDECK  ID>, PHO_ID2STR
31656       SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31657 C*********************************************************************
31658 C
31659 C     conversion of quark numbering scheme
31660 C
31661 C     input:   standard particle codes:
31662 C                       ID1
31663 C                       ID2
31664 C
31665 C     output:  NOBAM    CPC string code
31666 C              quark codes (PDG convention):
31667 C                       IBAM1
31668 C                       IBAM2
31669 C                       IBAM3
31670 C                       IBAM4
31671 C
31672 C              NOBAM = -1 invalid flavour combinations
31673 C
31674 C*********************************************************************
31675       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31676       SAVE
31677
31678 C  input/output channels
31679       INTEGER LI,LO
31680       COMMON /POINOU/ LI,LO
31681
31682       IDA1 = ABS(ID1)
31683       IDA2 = ABS(ID2)
31684
31685 C  quark-antiquark string
31686       IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31687         IF((ID1*ID2).GE.0) GOTO 100
31688         IBAM1 = ID1
31689         IBAM2 = ID2
31690         IBAM3 = 0
31691         IBAM4 = 0
31692         NOBAM = 3
31693 C  quark-diquark string
31694       ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31695         IF((ID1*ID2).LE.0) GOTO 100
31696         IBAM1 = ID1
31697         IBAM2 = ID2/1000
31698         IBAM3 = (ID2-IBAM2*1000)/100
31699         IBAM4 = 0
31700         NOBAM = 4
31701 C  diquark-quark string
31702       ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31703         IF((ID1*ID2).LE.0) GOTO 100
31704         IBAM1 = ID1/1000
31705         IBAM2 = (ID1-IBAM1*1000)/100
31706         IBAM3 = ID2
31707         IBAM4 = 0
31708         NOBAM = 6
31709 C  gluon-gluon string
31710       ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31711         IBAM1 = 21
31712         IBAM2 = 21
31713         IBAM3 = 0
31714         IBAM4 = 0
31715         NOBAM = 7
31716 C  diquark-antidiquark string
31717       ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31718         IF((ID1*ID2).GE.0) GOTO 100
31719         IBAM1 = ID1/1000
31720         IBAM2 = (ID1-IBAM1*1000)/100
31721         IBAM3 = ID2/1000
31722         IBAM4 = (ID2-IBAM3*1000)/100
31723         NOBAM = 5
31724       ENDIF
31725       RETURN
31726
31727 C  invalid combination
31728  100  CONTINUE
31729         WRITE(LO,'(//1X,A,2I10)')
31730      &    'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31731         CALL PHO_ABORT
31732
31733       END
31734
31735 CDECK  ID>, PHO_MKSLTR
31736       SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31737 C********************************************************************
31738 C
31739 C     calculate successive Lorentz boots for arbitrary Lorentz trans.
31740 C
31741 C     input:   P1                initial 4 vector
31742 C              GAM(3),GAMB(3)    Lorentz boost parameters
31743 C
31744 C     output:  P2                final  4 vector
31745 C
31746 C********************************************************************
31747       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31748       SAVE
31749
31750       DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31751
31752       P2(4) = P1(4)
31753       DO 150 I=1,3
31754         P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31755         P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
31756  150  CONTINUE
31757       END
31758
31759 CDECK  ID>, PHO_GETLTR
31760       SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
31761 C********************************************************************
31762 C
31763 C     calculate Lorentz boots for arbitrary Lorentz transformation
31764 C
31765 C     input:   P1    initial 4 vector
31766 C              P2    final 4 vector
31767 C
31768 C     output:  GAM(3),GAMB(3)
31769 C              DELE   energy deviation
31770 C              IREJ   0 success
31771 C                     1 failure
31772 C
31773 C********************************************************************
31774       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31775       SAVE
31776
31777       PARAMETER ( DREL = 0.001D0 )
31778
31779 C  input/output channels
31780       INTEGER LI,LO
31781       COMMON /POINOU/ LI,LO
31782
31783       DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
31784
31785       IREJ = 1
31786       DO 50 K=1,4
31787         PA(K) = P1(K)
31788         PP(K) = P1(K)
31789  50   CONTINUE
31790       PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
31791       DO 100 I=1,3
31792         PP(I) = P2(I)
31793         PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
31794         IF(PP(4).LE.0.D0) RETURN
31795         PP(4) = SQRT(PP(4))
31796         GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
31797      &             -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
31798         GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
31799         GAMB(I) = GAMB(I)*GAM(I)
31800         DO 150 K=1,4
31801           PA(K) = PP(K)
31802  150    CONTINUE
31803  100  CONTINUE
31804       DELE = P2(4)-PP(4)
31805       IREJ = 0
31806 C  consistency check
31807 *     IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
31808 *       PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
31809 *       WRITE(LO,'(/1X,A,2E12.5)')
31810 *    &    'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
31811 *       WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
31812 *       WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
31813 *       WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
31814 *       WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
31815 *     ENDIF
31816       END
31817
31818 CDECK  ID>, PHO_ALTRA
31819       SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
31820 C*********************************************************************
31821 C
31822 C    arbitrary Lorentz transformation
31823 C
31824 C*********************************************************************
31825       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31826       SAVE
31827
31828       EP=PCX*BGX+PCY*BGY+PCZ*BGZ
31829       PE=EP/(GA+1.D0)+EC
31830       PX=PCX+BGX*PE
31831       PY=PCY+BGY*PE
31832       PZ=PCZ+BGZ*PE
31833       P=SQRT(PX*PX+PY*PY+PZ*PZ)
31834       E=GA*EC+EP
31835
31836       END
31837
31838 CDECK  ID>, PHO_LTRANS
31839       SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
31840      &                 PL,CXL,CYL,CZL,EL)
31841 C**********************************************************************
31842 C
31843 C     Lorentz transformation into lab - system
31844 C
31845 C**********************************************************************
31846       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31847       SAVE
31848
31849       PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
31850
31851 C  input/output channels
31852       INTEGER LI,LO
31853       COMMON /POINOU/ LI,LO
31854
31855       SID=SQRT(1.D0-COD*COD)
31856       PLX=P*SID*COF
31857       PLY=P*SID*SIF
31858       PCMZ=P*COD
31859       PLZ=GAM*PCMZ+BGAM*ECM
31860       PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
31861       EL=GAM*ECM+BGAM*PCMZ
31862
31863 C  rotation into the original direction
31864       COZ=PLZ/PL
31865       SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
31866
31867 *      CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
31868
31869       AX=ABS(CX)
31870       AY=ABS(CY)
31871       IF(AX.LT.AY) THEN
31872         AMAX=AY
31873         AMIN=AX
31874       ELSE
31875         AMAX=AX
31876         AMIN=AY
31877       ENDIF
31878       IF (ABS(CX)-TINY) 1,1,2
31879     1 IF (ABS(CY)-TINY) 3,3,2
31880
31881     3 CONTINUE
31882 *     WRITE(LO,*)' PHO_DTRANS CX CY CZ =',CX,CY,CZ
31883       CXL=SIZ*COF
31884       CYL=SIZ*SIF
31885       CZL=COZ*CZ
31886 *     WRITE(LO,*)' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
31887 *     WRITE(LO,*) CXL,CYL,CZL
31888       RETURN
31889
31890     2 CONTINUE
31891       IF(AMAX.GT.TINY2) THEN
31892         AR=AMIN/AMAX
31893         AR=AR*AR
31894         A=AMAX*SQRT(1.D0+AR)
31895       ELSE
31896 *       WRITE(LO,*)' PHO_DTRANS AMAX LE TINY2 '
31897         GOTO 3
31898       ENDIF
31899       XI=SIZ*COF
31900       YI=SIZ*SIF
31901       ZI=COZ
31902       CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
31903       CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
31904       CZL=A*YI+CZ*ZI
31905
31906       END
31907
31908 CDECK  ID>, PHO_TRANS
31909       SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31910 C**********************************************************************
31911 C
31912 C  rotation of coordinate frame (1) de rotation around y axis
31913 C                               (2) fe rotation around z axis
31914 C  (inverse rotation to PHO_TRANI)
31915 C
31916 C**********************************************************************
31917       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31918       SAVE
31919
31920       X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
31921       Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
31922       Z=-SDE    *XO       +CDE    *ZO
31923
31924       END
31925
31926 CDECK  ID>, PHO_TRANI
31927       SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31928 C**********************************************************************
31929 C
31930 C  rotation of coordinate frame (1) -fe rotation around z axis
31931 C                               (2) -de rotation around y axis
31932 C  (inverse rotation to PHO_TRANS)
31933 C
31934 C**********************************************************************
31935       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31936       SAVE
31937
31938       X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
31939       Y=-SFE    *XO+CFE*    YO
31940       Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
31941
31942       END
31943
31944 CDECK  ID>, pho_cpcini
31945       SUBROUTINE pho_cpcini(Nrows,Number,List)
31946 C***********************************************************************
31947 C
31948 C     initialization of particle hash table
31949 C
31950 C     input:   Number     vector with Nrows entries according to PDG
31951 C                         convention
31952 C
31953 C     output:  List       vector with hash table
31954 C
31955 C     (this code is based on the function initpns written by
31956 C      Gerry Lynch, LBL, January 1990)
31957 C
31958 C***********************************************************************
31959
31960       IMPLICIT NONE
31961
31962       SAVE
31963
31964 C  input/output channels
31965       INTEGER LI,LO
31966       COMMON /POINOU/ LI,LO
31967
31968       integer Number(*),List(*),Nrows
31969
31970       Integer Nin,Nout,Ip,I
31971
31972       do I = 1,577
31973         List(I) = 0
31974       enddo
31975
31976 C    Loop over all of the elements in the Number vector
31977
31978         Do 500 Ip = 1,Nrows
31979             Nin = Number(Ip)
31980
31981 C    Calculate a list number for this particle id number
31982             If(Nin.Gt.99999.or.Nin.Le.0) Then
31983                  Nout = -1
31984             Else If(Nin.Le.577) Then
31985                  Nout = Nin
31986             Else
31987                  Nout = Mod(Nin,577)
31988             End If
31989
31990  200        continue
31991
31992             If(Nout.Lt.0) Then
31993 C    Count the bad entries
31994                 WRITE(LO,'(1x,a,i10)')
31995      &            'pho_cpcini: invalid particle ID',Nin
31996                 Go to 500
31997             End If
31998             If(List(Nout).eq.0) Then
31999                 List(Nout) = Ip
32000             Else
32001                 If(Nin.eq.Number(List(Nout))) Then
32002                   WRITE(LO,'(1x,a,i10)')
32003      &              'pho_cpcini: double particle ID',Nin
32004                 End If
32005                 Nout = Nout + 5
32006                 If(Nout.Gt.577) Nout = Mod(Nout, 577)
32007
32008                 Go to 200
32009             End If
32010  500      Continue
32011
32012       END
32013
32014 CDECK  ID>, ipho_pdg2id
32015       INTEGER FUNCTION ipho_pdg2id(IDpdg)
32016 C**********************************************************************
32017 C
32018 C     calculation internal particle code using the particle index i
32019 C     according to the PDG proposal.
32020 C
32021 C     input:  IDpdg          PDG particle number
32022 C     output: ipho_pdg2id    internal particle code
32023 C                            (0 for invalid IDpdg)
32024 C
32025 C     the hash algorithm is based on a program by Gerry Lynch
32026 C
32027 C**********************************************************************
32028
32029       IMPLICIT NONE
32030
32031       SAVE
32032
32033       integer IDpdg
32034
32035 C  input/output channels
32036       INTEGER LI,LO
32037       COMMON /POINOU/ LI,LO
32038 C  event debugging information
32039       INTEGER NMAXD
32040       PARAMETER (NMAXD=100)
32041       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32042      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32043       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32044      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32045 C  particle ID translation table
32046       integer         ID_pdg_list,ID_list,ID_pdg_max
32047       character*12    name_list
32048       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32049      &                ID_pdg_max
32050
32051       integer Nin,Nout
32052       Nin = abs(IDpdg)
32053
32054       if((Nin.gt.99999).or.(Nin.eq.0)) then
32055 C  invalid particle number
32056         if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32057      &    'ipho_pdg2id: invalid PDG ID number ',IDpdg
32058         ipho_pdg2id = 0
32059         return
32060       else If(Nin.le.577) then
32061 C  simple case
32062         Nout = Nin
32063       else
32064 C  use hash algorithm
32065         Nout = mod(Nin,577)
32066       endif
32067
32068  100  continue
32069
32070 C  particle not in table
32071       if(ID_list(Nout).Eq.0) then
32072         if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32073      &    'ipho_pdg2id: particle not in table ',IDpdg
32074         ipho_pdg2id = 0
32075         return
32076       endif
32077
32078       if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32079 C  particle ID found
32080         ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32081         return
32082       else
32083 C  increment and try again
32084         Nout = Nout + 5
32085         If(Nout.gt.577) Nout = Mod(Nout,577)
32086         goto 100
32087       endif
32088
32089       END
32090
32091 CDECK  ID>, IPHO_ID2PDG
32092       INTEGER FUNCTION ipho_id2pdg(IDcpc)
32093 C**********************************************************************
32094 C
32095 C     conversion of internal particle code to PDG standard
32096 C
32097 C     input:     IDcpc        internal particle number
32098 C     output:    ipho_id2pdg  PDG particle number
32099 C                             (0 for invalid IDcpc)
32100 C
32101 C**********************************************************************
32102
32103       IMPLICIT NONE
32104
32105       SAVE
32106
32107       integer IDcpc
32108
32109 C  input/output channels
32110       INTEGER LI,LO
32111       COMMON /POINOU/ LI,LO
32112 C  event debugging information
32113       INTEGER NMAXD
32114       PARAMETER (NMAXD=100)
32115       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32116      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32117       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32118      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32119 C  particle ID translation table
32120       integer         ID_pdg_list,ID_list,ID_pdg_max
32121       character*12    name_list
32122       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32123      &                ID_pdg_max
32124
32125       integer IDabs
32126
32127       IDabs = abs(IDcpc)
32128       if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32129         ipho_id2pdg = 0
32130         return
32131       endif
32132
32133       ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32134
32135       END
32136
32137 CDECK  ID>, IPHO_LU2PDG
32138       INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32139 C**********************************************************************
32140 C
32141 C    conversion of JETSET KF code to PDG code
32142 C
32143 C**********************************************************************
32144       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32145       SAVE
32146       PARAMETER (NTAB=10)
32147       DIMENSION LU2PD(2,NTAB)
32148       DATA LU2PD / 4232, 4322,
32149      &             4322, 4232,
32150      &             3212, 3122,
32151      &             3122, 3212,
32152      &            30553, 20553,
32153      &            30443, 20443,
32154      &            20443, 10443,
32155      &            10443, 0,
32156      &            511,   0,
32157      &            10551, 551 /
32158 C
32159       DO 100 I=1,NTAB
32160         IF(LU2PD(1,I).EQ.LUKF) THEN
32161           IPHO_LU2PDG=LU2PD(2,I)
32162           RETURN
32163         ENDIF
32164  100  CONTINUE
32165       IPHO_LU2PDG=LUKF
32166
32167       END
32168
32169 CDECK  ID>, IPHO_PDG2LU
32170       INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32171 C**********************************************************************
32172 C
32173 C    conversion of PDG code to JETSET code
32174 C
32175 C**********************************************************************
32176       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32177       SAVE
32178       PARAMETER (NTAB=8)
32179       DIMENSION LU2PD(2,NTAB)
32180       DATA LU2PD / 4232, 4322,
32181      &             4322, 4232,
32182      &             3212, 3122,
32183      &             3122, 3212,
32184      &            30553, 20553,
32185      &            30443, 20443,
32186      &            20443, 10443,
32187      &            10551, 551 /
32188 C
32189       DO 100 I=1,NTAB
32190         IF(LU2PD(2,I).EQ.IPDG) THEN
32191           IPHO_PDG2LU=LU2PD(1,I)
32192           RETURN
32193         ENDIF
32194  100  CONTINUE
32195       IPHO_PDG2LU=IPDG
32196
32197       END
32198
32199 CDECK  ID>, pho_pname
32200       CHARACTER*15 FUNCTION pho_pname(ID,mode)
32201 C***********************************************************************
32202 C
32203 C     returns particle name for given ID number
32204 C
32205 C     input:  ID      particle ID number
32206 C             mode    0:   ID treated as compressed particle code
32207 C                     1:   ID treated as PDG number
32208 C
32209 C***********************************************************************
32210
32211       IMPLICIT NONE
32212
32213       SAVE
32214
32215       integer ID,mode
32216
32217 C  input/output channels
32218       INTEGER LI,LO
32219       COMMON /POINOU/ LI,LO
32220
32221 C  standard particle data interface
32222       INTEGER NMXHEP
32223
32224       PARAMETER (NMXHEP=4000)
32225
32226       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32227       DOUBLE PRECISION PHEP,VHEP
32228       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32229      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32230      &                VHEP(4,NMXHEP)
32231 C  extension to standard particle data interface (PHOJET specific)
32232       INTEGER IMPART,IPHIST,ICOLOR
32233       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32234
32235 C  particle ID translation table
32236       integer         ID_pdg_list,ID_list,ID_pdg_max
32237       character*12    name_list
32238       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32239      &                ID_pdg_max
32240 C  general particle data
32241       double precision xm_list,tau_list,gam_list,
32242      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32243      &  xm_bb82_list,xm_bb102_list
32244       integer          ich3_list,iba3_list,iq_list,
32245      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32246       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32247      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32248      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32249      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32250      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32251      &  id_psm_list(6,6),id_vem_list(6,6),
32252      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32253
32254 C  external functions
32255       integer ipho_id2pdg,ipho_pdg2id
32256
32257 C  local variables
32258       integer  IDpdg,i,ii,k,l,ichar,i_anti
32259       character*15 name
32260
32261       pho_pname = '(?????????????)'
32262
32263       if(mode.eq.0) then
32264         i = ID
32265         IDpdg = ipho_id2pdg(ID)
32266         if(IDpdg.eq.0) return
32267       else if(mode.eq.1) then
32268         i = ipho_pdg2id(ID)
32269         if(i.eq.0) return
32270         IDpdg = ID
32271       else if(mode.eq.2) then
32272         if(ISTHEP(ID).gt.11) then
32273           if(ISTHEP(ID).eq.20) then
32274             pho_pname = 'hard ini. part.'
32275           else if(ISTHEP(ID).eq.21) then
32276             pho_pname = 'hard fin. part.'
32277           else if(ISTHEP(ID).eq.25) then
32278             pho_pname = 'hard scattering'
32279           else if(ISTHEP(ID).eq.30) then
32280             pho_pname = 'diff. diss.    '
32281           else if(ISTHEP(ID).eq.35) then
32282             pho_pname = 'elastic scatt. '
32283           else if(ISTHEP(ID).eq.40) then
32284             pho_pname = 'central scatt. '
32285           endif
32286           return
32287         endif
32288         IDpdg = IDHEP(ID)
32289         i     = IMPART(ID)
32290       else
32291         WRITE(LO,'(1x,a,2i4)')
32292      &    'pho_pname: invalid arguments (ID,mode): ',ID,mode
32293         return
32294       endif
32295
32296       ii = abs(i)
32297       if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32298
32299       name = name_list(ii)
32300       ichar = ich3_list(ii)*sign(1,i)
32301       if(mod(ichar,3).ne.0) then
32302         ichar = 0
32303       else
32304         ichar = ichar/3
32305       endif
32306
32307 C  find position of first blank character
32308       k = 1
32309  100  continue
32310         k = k+1
32311       if(name(k:k).ne.' ') goto 100
32312
32313 C  append anti-particle sign
32314       if(i.lt.0) then
32315         i_anti = 0
32316         do l=1,3
32317           i_anti = i_anti+iq_list(l,ii)
32318         enddo
32319         if(iba3_list(ii).ne.0) then
32320           name(k:k) = '~'
32321           k = K+1
32322         else if(((i_anti.ne.0).and.(ichar.eq.0))
32323      &          .or.(IDpdg.eq.-12)
32324      &          .or.(IDpdg.eq.-14)
32325      &          .or.(IDpdg.eq.-16)) then
32326           name(k:k) = '~'
32327           k = K+1
32328         endif
32329       endif
32330
32331 C  append charge sign
32332       if(ichar.eq.-2) then
32333         name(k:k+1) = '--'
32334       else if(ichar.eq.-1) then
32335         name(k:k) = '-'
32336       else if(ichar.eq.1) then
32337         name(k:k) = '+'
32338       else if(ichar.eq.2) then
32339         name(k:k+1) = '++'
32340       endif
32341
32342       pho_pname = name
32343
32344       END
32345
32346 CDECK  ID>, ipho_anti
32347       INTEGER FUNCTION ipho_anti(ID)
32348 C**********************************************************************
32349 C
32350 C     determine antiparticle for given ID
32351 C
32352 C     input:  ID gives CPC particle number
32353 C
32354 C     output: ipho_anti antiparticle code
32355 C
32356 C**********************************************************************
32357
32358       IMPLICIT NONE
32359
32360       SAVE
32361
32362       integer ID
32363
32364 C  input/output channels
32365       INTEGER LI,LO
32366       COMMON /POINOU/ LI,LO
32367 C  event debugging information
32368       INTEGER NMAXD
32369       PARAMETER (NMAXD=100)
32370       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32371      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32372       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32373      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32374 C  particle ID translation table
32375       integer         ID_pdg_list,ID_list,ID_pdg_max
32376       character*12    name_list
32377       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32378      &                ID_pdg_max
32379 C  general particle data
32380       double precision xm_list,tau_list,gam_list,
32381      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32382      &  xm_bb82_list,xm_bb102_list
32383       integer          ich3_list,iba3_list,iq_list,
32384      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32385       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32386      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32387      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32388      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32389      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32390      &  id_psm_list(6,6),id_vem_list(6,6),
32391      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32392
32393 C  standard particle data interface
32394       INTEGER NMXHEP
32395
32396       PARAMETER (NMXHEP=4000)
32397
32398       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32399       DOUBLE PRECISION PHEP,VHEP
32400       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32401      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32402      &                VHEP(4,NMXHEP)
32403 C  extension to standard particle data interface (PHOJET specific)
32404       INTEGER IMPART,IPHIST,ICOLOR
32405       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32406
32407 C  external functions
32408       integer ipho_id2pdg,ipho_pdg2id
32409
32410 C  local variables
32411       integer IDabs,IDpdg,i_anti,l
32412
32413       ipho_anti = -ID
32414       IDabs = abs(ID)
32415
32416 C  baryons
32417       if(iba3_list(IDabs).ne.0) return
32418
32419 C  charged particles
32420       if(ich3_list(IDabs).ne.0) return
32421
32422 C  K0_s and K0_l
32423       IDpdg = ipho_id2pdg(ID)
32424       if(IDpdg.eq.310) then
32425         ID = ipho_pdg2id(130)
32426         return
32427       else if(IDpdg.eq.130) then
32428         ID = ipho_pdg2id(310)
32429         return
32430       endif
32431
32432 C  neutral mesons with open strangeness, charm, or beauty
32433       i_anti = 0
32434       do l=1,3
32435         i_anti = i_anti+iq_list(l,IDabs)
32436       enddo
32437       if(i_anti.ne.0) return
32438
32439 C  neutrinos
32440       IDpdg = abs(IDpdg)
32441       if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32442
32443       ipho_anti = ID
32444
32445       END
32446
32447 CDECK  ID>, ipho_chr3
32448       INTEGER FUNCTION ipho_chr3(ID,mode)
32449 C**********************************************************************
32450 C
32451 C     output of three times the electric charge
32452 C
32453 C     input:  mode
32454 C             0   ID gives CPC particle number
32455 C             1   ID gives PDG particle number
32456 C             2   ID gives position of particle in /POEVT1/
32457 C
32458 C**********************************************************************
32459
32460       IMPLICIT NONE
32461
32462       SAVE
32463
32464       integer ID,mode
32465
32466 C  input/output channels
32467       INTEGER LI,LO
32468       COMMON /POINOU/ LI,LO
32469 C  event debugging information
32470       INTEGER NMAXD
32471       PARAMETER (NMAXD=100)
32472       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32473      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32474       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32475      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32476
32477 C  standard particle data interface
32478       INTEGER NMXHEP
32479
32480       PARAMETER (NMXHEP=4000)
32481
32482       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32483       DOUBLE PRECISION PHEP,VHEP
32484       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32485      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32486      &                VHEP(4,NMXHEP)
32487 C  extension to standard particle data interface (PHOJET specific)
32488       INTEGER IMPART,IPHIST,ICOLOR
32489       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32490
32491 C  particle ID translation table
32492       integer         ID_pdg_list,ID_list,ID_pdg_max
32493       character*12    name_list
32494       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32495      &                ID_pdg_max
32496 C  general particle data
32497       double precision xm_list,tau_list,gam_list,
32498      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32499      &  xm_bb82_list,xm_bb102_list
32500       integer          ich3_list,iba3_list,iq_list,
32501      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32502       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32503      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32504      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32505      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32506      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32507      &  id_psm_list(6,6),id_vem_list(6,6),
32508      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32509
32510 C  external functions
32511       integer ipho_pdg2id
32512
32513 C  local variables
32514       integer i,IDpdg
32515
32516       ipho_chr3 = 0
32517
32518       if(mode.eq.0) then
32519         i = ID
32520       else if(mode.eq.1) then
32521         i = ipho_pdg2id(ID)
32522         if(i.eq.0) return
32523         IDpdg = ID
32524       else if(mode.eq.2) then
32525         if(ISTHEP(ID).gt.11) return
32526         i     = IMPART(ID)
32527         IDpdg = IDHEP(ID)
32528         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32529           ipho_chr3 = ICOLOR(1,ID)
32530           return
32531         endif
32532       else
32533         WRITE(LO,'(1x,a,2i4)')
32534      &    'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32535         return
32536       endif
32537
32538       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32539         WRITE(LO,'(1x,a,3i8)')
32540      &    'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32541         ipho_chr3 = 1.D0/dble(i)
32542         call pho_prevnt(0)
32543         return
32544       endif
32545
32546       ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32547
32548       END
32549
32550 CDECK  ID>, ipho_bar3
32551       INTEGER FUNCTION ipho_bar3(ID,mode)
32552 C**********************************************************************
32553 C
32554 C     output of three times the baryon charge
32555 C
32556 C     index:  MODE
32557 C             0   ID gives CPC particle number
32558 C             1   ID gives PDG particle number
32559 C             2   ID gives position of particle in /POEVT1/
32560 C
32561 C**********************************************************************
32562
32563       IMPLICIT NONE
32564
32565       SAVE
32566
32567       integer ID,mode
32568
32569 C  input/output channels
32570       INTEGER LI,LO
32571       COMMON /POINOU/ LI,LO
32572 C  event debugging information
32573       INTEGER NMAXD
32574       PARAMETER (NMAXD=100)
32575       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32576      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32577       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32578      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32579
32580 C  standard particle data interface
32581       INTEGER NMXHEP
32582
32583       PARAMETER (NMXHEP=4000)
32584
32585       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32586       DOUBLE PRECISION PHEP,VHEP
32587       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32588      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32589      &                VHEP(4,NMXHEP)
32590 C  extension to standard particle data interface (PHOJET specific)
32591       INTEGER IMPART,IPHIST,ICOLOR
32592       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32593
32594 C  particle ID translation table
32595       integer         ID_pdg_list,ID_list,ID_pdg_max
32596       character*12    name_list
32597       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32598      &                ID_pdg_max
32599 C  general particle data
32600       double precision xm_list,tau_list,gam_list,
32601      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32602      &  xm_bb82_list,xm_bb102_list
32603       integer          ich3_list,iba3_list,iq_list,
32604      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32605       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32606      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32607      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32608      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32609      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32610      &  id_psm_list(6,6),id_vem_list(6,6),
32611      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32612
32613 C  external functions
32614       integer ipho_pdg2id
32615
32616 C  local variables
32617       integer i,IDpdg
32618
32619       ipho_bar3 = 0
32620
32621       if(mode.eq.0) then
32622         i = ID
32623       else if(mode.eq.1) then
32624         i = ipho_pdg2id(ID)
32625         if(i.eq.0) return
32626         IDpdg = ID
32627       else if(mode.eq.2) then
32628         if(ISTHEP(ID).gt.11) return
32629         i     = IMPART(ID)
32630         IDpdg = IDHEP(ID)
32631         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32632           ipho_bar3 = ICOLOR(2,ID)
32633           return
32634         endif
32635       else
32636         WRITE(LO,'(1x,a,2i4)')
32637      &    'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32638         return
32639       endif
32640
32641       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32642         WRITE(LO,'(1x,a,3i8)')
32643      &    'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32644         ipho_bar3 = 1.D0/dble(i)
32645         return
32646       endif
32647
32648       ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32649
32650       END
32651
32652 CDECK  ID>, pho_pmass
32653       DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32654 C***********************************************************************
32655 C
32656 C     particle mass
32657 C
32658 C     input:  mode  -1   initialization
32659 C                    0   ID gives CPC particle number
32660 C                    1   ID gives PDG particle number,
32661 C                        (for quarks current masses are returned)
32662 C                    2   ID gives position of particle in /POEVT1/
32663 C                    3   ID gives PDG parton number,
32664 C                        (for quarks constituent masses are returned)
32665 C
32666 C     output: average particle mass (in GeV)
32667 C
32668 C***********************************************************************
32669
32670       IMPLICIT NONE
32671
32672       SAVE
32673
32674       integer ID,mode,MSTJ24
32675
32676 C  input/output channels
32677       INTEGER LI,LO
32678       COMMON /POINOU/ LI,LO
32679 C  event debugging information
32680       INTEGER NMAXD
32681       PARAMETER (NMAXD=100)
32682       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32683      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32684       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32685      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32686 C  model switches and parameters
32687       CHARACTER*8 MDLNA
32688       INTEGER ISWMDL,IPAMDL
32689       DOUBLE PRECISION PARMDL
32690       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32691
32692 C  standard particle data interface
32693       INTEGER NMXHEP
32694
32695       PARAMETER (NMXHEP=4000)
32696
32697       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32698       DOUBLE PRECISION PHEP,VHEP
32699       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32700      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32701      &                VHEP(4,NMXHEP)
32702 C  extension to standard particle data interface (PHOJET specific)
32703       INTEGER IMPART,IPHIST,ICOLOR
32704       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32705
32706 C  particle ID translation table
32707       integer         ID_pdg_list,ID_list,ID_pdg_max
32708       character*12    name_list
32709       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32710      &                ID_pdg_max
32711 C  general particle data
32712       double precision xm_list,tau_list,gam_list,
32713      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32714      &  xm_bb82_list,xm_bb102_list
32715       integer          ich3_list,iba3_list,iq_list,
32716      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32717       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32718      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32719      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32720      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32721      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32722      &  id_psm_list(6,6),id_vem_list(6,6),
32723      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32724
32725       INTEGER MSTU,MSTJ
32726       DOUBLE PRECISION PARU,PARJ
32727       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32728
32729 C  external functions
32730       integer ipho_pdg2id,ipho_id2pdg
32731
32732       DOUBLE PRECISION PYMASS
32733
32734 C  local variables
32735       integer i,IDpdg
32736
32737       pho_pmass = 0.D0
32738
32739       if(mode.eq.0) then
32740         i = ID
32741       else if(mode.eq.1) then
32742         i = ipho_pdg2id(ID)
32743         if(i.eq.0) return
32744       else if(mode.eq.2) then
32745         if(ISTHEP(ID).gt.11) return
32746         i     = IMPART(ID)
32747         IDpdg = IDHEP(ID)
32748         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32749           pho_pmass = PHEP(5,ID)
32750           return
32751         endif
32752       else if(mode.eq.3) then
32753         i = abs(ID)
32754         if((i.gt.0).and.(i.le.6)) then
32755           pho_pmass = PARMDL(150+i)
32756           return
32757         else
32758           i = ipho_pdg2id(ID)
32759           if(i.eq.0) return
32760         endif
32761       else if(mode.eq.-1) then
32762 C  initialization: take masses for quarks and di-quarks from JETSET
32763         MSTJ24 = MSTJ(24)
32764         MSTJ(24) = 0
32765         do i=1,22
32766           IDpdg = ipho_id2pdg(i)
32767
32768           xm_list(i) = PYMASS(IDpdg)
32769
32770         enddo
32771         MSTJ(24) = MSTJ24
32772         return
32773       else
32774         WRITE(LO,'(1x,a,2i4)')
32775      &    'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32776         return
32777       endif
32778
32779       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32780         WRITE(LO,'(1x,a,2i8)')
32781      &    'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32782         pho_pmass = 1.D0/dble(i)
32783         return
32784       endif
32785
32786       pho_pmass = xm_list(iabs(i))
32787
32788       END
32789
32790 CDECK  ID>, PHO_MEMASS
32791       SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
32792 C**********************************************************************
32793 C
32794 C     determine meson masses corresponding to the input flavours
32795 C
32796 C     input: I,J,K     quark flavours (PDG convention)
32797 C
32798 C     output: AMPS     pseudo scalar meson mass
32799 C             AMPS2    next possible two particle configuration
32800 C                      (two pseudo scalar  mesons)
32801 C             AMVE     vector meson mass
32802 C             AMVE2    next possible two particle configuration
32803 C                      (two vector mesons)
32804 C             IPS,IVE  meson numbers in CPC
32805 C
32806 C**********************************************************************
32807
32808       IMPLICIT NONE
32809
32810       SAVE
32811
32812       integer I,J,IPS,IVE
32813       double precision AMPS,AMPS2,AMVE,AMVE2
32814
32815 C  input/output channels
32816       INTEGER LI,LO
32817       COMMON /POINOU/ LI,LO
32818 C  event debugging information
32819       INTEGER NMAXD
32820       PARAMETER (NMAXD=100)
32821       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32822      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32823       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32824      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32825 C  particle ID translation table
32826       integer         ID_pdg_list,ID_list,ID_pdg_max
32827       character*12    name_list
32828       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32829      &                ID_pdg_max
32830 C  general particle data
32831       double precision xm_list,tau_list,gam_list,
32832      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32833      &  xm_bb82_list,xm_bb102_list
32834       integer          ich3_list,iba3_list,iq_list,
32835      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32836       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32837      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32838      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32839      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32840      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32841      &  id_psm_list(6,6),id_vem_list(6,6),
32842      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32843
32844 C  local variables
32845       integer ii,jj
32846
32847       IF(I.GT.0) THEN
32848         ii = I
32849         jj = -J
32850       ELSE
32851         ii = J
32852         jj = -I
32853       ENDIF
32854
32855 C  particle ID's
32856       IPS = id_psm_list(ii,jj)
32857       IVE = id_vem_list(ii,jj)
32858 C  masses
32859       if(IPS.ne.0) then
32860         AMPS = xm_list(iabs(IPS))
32861       else
32862         AMPS = 0.D0
32863       endif
32864       if(IVE.ne.0) then
32865         AMVE = xm_list(iabs(IVE))
32866       else
32867         AMVE = 0.D0
32868       endif
32869
32870 C  next possible two-particle configurations (add phase space)
32871       AMPS2 = xm_psm2_list(ii,jj)*1.5D0
32872       AMVE2 = xm_vem2_list(ii,jj)*1.1D0
32873
32874       END
32875
32876 CDECK  ID>, PHO_BAMASS
32877       SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
32878 C**********************************************************************
32879 C
32880 C     determine baryon masses corresponding to the input flavours
32881 C
32882 C     input: I,J,K     quark flavours (PDG convention)
32883 C
32884 C     output: AM8      octett baryon mass
32885 C             AM82     next possible two particle configuration
32886 C                      (octett baryon and meson)
32887 C             AM10     decuplett baryon mass
32888 C             AM102    next possible two particle configuration
32889 C                      (decuplett baryon and meson,
32890 C                       baryon built up from first two quarks)
32891 C             I8,I10   internal baryon numbers
32892 C
32893 C**********************************************************************
32894
32895       IMPLICIT NONE
32896
32897       SAVE
32898
32899       integer I,J,K,I8,I10
32900       double precision AM8,AM82,AM10,AM102
32901
32902 C  input/output channels
32903       INTEGER LI,LO
32904       COMMON /POINOU/ LI,LO
32905 C  event debugging information
32906       INTEGER NMAXD
32907       PARAMETER (NMAXD=100)
32908       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32909      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32910       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32911      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32912 C  particle ID translation table
32913       integer         ID_pdg_list,ID_list,ID_pdg_max
32914       character*12    name_list
32915       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32916      &                ID_pdg_max
32917 C  general particle data
32918       double precision xm_list,tau_list,gam_list,
32919      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32920      &  xm_bb82_list,xm_bb102_list
32921       integer          ich3_list,iba3_list,iq_list,
32922      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32923       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32924      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32925      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32926      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32927      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32928      &  id_psm_list(6,6),id_vem_list(6,6),
32929      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32930
32931 C  local variables
32932       integer ii,jj,kk
32933
32934 C  find particle ID's
32935       ii = iabs(I)
32936       jj = iabs(J)
32937       kk = iabs(K)
32938       I8  = id_b8_list(ii,jj,kk)
32939       I10 = id_b10_list(ii,jj,kk)
32940
32941 C  masses (if combination possible)
32942       if(I8.ne.0) then
32943         AM8 = xm_list(I8)
32944         I8  = sign(I8,i)
32945       else
32946         AM8 = 0.D0
32947       endif
32948       if(I10.ne.0) then
32949         AM10 = xm_list(I10)
32950         I10  = sign(I10,i)
32951       else
32952         AM10 = 0.D0
32953       endif
32954
32955 C  next possible two-particle configurations (add phase space)
32956       AM82  = xm_b82_list(ii,jj,kk)*1.5D0
32957       AM102 = xm_b102_list(ii,jj,kk)*1.1D0
32958
32959       END
32960
32961 CDECK  ID>, PHO_DQMASS
32962       SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
32963 C**********************************************************************
32964 C
32965 C     determine minimal masses corresponding to the input flavours
32966 C     (diquark a-diquark string system)
32967 C
32968 C     input: I,J,K,L   quark flavours (PDG convention)
32969 C
32970 C     output: AM82     mass of two octett baryons
32971 C             AM102    mass of two decuplett baryons
32972 C
32973 C**********************************************************************
32974
32975       IMPLICIT NONE
32976
32977       SAVE
32978
32979       integer I,J,K,L
32980       double precision AM82,AM102
32981
32982 C  input/output channels
32983       INTEGER LI,LO
32984       COMMON /POINOU/ LI,LO
32985 C  event debugging information
32986       INTEGER NMAXD
32987       PARAMETER (NMAXD=100)
32988       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32989      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32990       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32991      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32992 C  general particle data
32993       double precision xm_list,tau_list,gam_list,
32994      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32995      &  xm_bb82_list,xm_bb102_list
32996       integer          ich3_list,iba3_list,iq_list,
32997      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32998       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32999      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
33000      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33001      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33002      &  ich3_list(300),iba3_list(300),iq_list(3,300),
33003      &  id_psm_list(6,6),id_vem_list(6,6),
33004      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
33005
33006 C  local variables
33007       integer ii,jj,kk,ll
33008
33009       ii = iabs(i)
33010       kk = iabs(k)
33011       jj = iabs(j)
33012       ll = iabs(l)
33013
33014       AM82  = xm_bb82_list(ii,jj,kk,ll)
33015       AM102 = xm_bb102_list(ii,jj,kk,ll)
33016
33017       END
33018
33019 CDECK  ID>, PHO_CHECK
33020       SUBROUTINE PHO_CHECK(MD,IDEV)
33021 C**********************************************************************
33022 C
33023 C     check quantum numbers of entries in /POEVT1/ and /POEVT2/
33024 C           (energy, momentum, charge, baryon number conservation)
33025 C
33026 C     input:    MD      -1  check overall momentum conservation
33027 C                           and perform detailed check only in case of
33028 C                           deviations
33029 C                        1  test all branchings, mother-daughter
33030 C                           relations
33031 C
33032 C     output:   IDEV     0  no deviations
33033 C                        1  deviations found
33034 C
33035 C**********************************************************************
33036       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33037       SAVE
33038
33039 C  input/output channels
33040       INTEGER LI,LO
33041       COMMON /POINOU/ LI,LO
33042 C  event debugging information
33043       INTEGER NMAXD
33044       PARAMETER (NMAXD=100)
33045       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33046      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33047       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33048      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33049 C  model switches and parameters
33050       CHARACTER*8 MDLNA
33051       INTEGER ISWMDL,IPAMDL
33052       DOUBLE PRECISION PARMDL
33053       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33054 C  global event kinematics and particle IDs
33055       INTEGER IFPAP,IFPAB
33056       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33057       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33058 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
33059       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33060       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33061       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33062      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33063
33064 C  standard particle data interface
33065       INTEGER NMXHEP
33066
33067       PARAMETER (NMXHEP=4000)
33068
33069       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33070       DOUBLE PRECISION PHEP,VHEP
33071       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33072      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33073      &                VHEP(4,NMXHEP)
33074 C  extension to standard particle data interface (PHOJET specific)
33075       INTEGER IMPART,IPHIST,ICOLOR
33076       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33077
33078 C  color string configurations including collapsed strings and hadrons
33079       INTEGER MSTR
33080       PARAMETER (MSTR=500)
33081       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33082       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33083      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33084      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33085
33086 C  count number of errors to avoid disk overflow
33087       DATA IERR / 0 /
33088
33089       IDEV = 0
33090 C  conservation check suppressed
33091       IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33092
33093       IF(IPAMDL(13).GT.0) THEN
33094
33095 C  DPMJET call with x limitations
33096         MODE = -1
33097         ECM1 = SQRT(XPSUB*XTSUB)*ECM
33098
33099       ELSE
33100
33101 C  standard call
33102         MODE = MD
33103 C  first two entries are considered as scattering particles
33104         EE1 = PHEP(4,1) + PHEP(4,2)
33105         PX1 = PHEP(1,1) + PHEP(1,2)
33106         PY1 = PHEP(2,1) + PHEP(2,2)
33107         PZ1 = PHEP(3,1) + PHEP(3,2)
33108
33109       ENDIF
33110
33111       DDREL = PARMDL(75)
33112       DDABS = PARMDL(76)
33113       IF(MODE.EQ.-1) GOTO 500
33114
33115  50   CONTINUE
33116
33117       I = 1
33118  100  CONTINUE
33119
33120 C  recognize only decayed particles as mothers
33121         IF(ISTHEP(I).EQ.2) THEN
33122 C  search for other mother particles
33123           K = JDAHEP(1,I)
33124           IF(K.EQ.0) THEN
33125             IF(IPAMDL(178).NE.0)
33126      &        WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33127      &        'entry marked as decayed but no dauther given:',I
33128             GOTO 99
33129           ENDIF
33130           K1 = JMOHEP(1,K)
33131           K2 = JMOHEP(2,K)
33132 C  sum over mother particles
33133           ICH1 = IPHO_CHR3(K1,2)
33134           IBA1 = IPHO_BAR3(K1,2)
33135           EE1 = PHEP(4,K1)
33136           PX1 = PHEP(1,K1)
33137           PY1 = PHEP(2,K1)
33138           PZ1 = PHEP(3,K1)
33139           IF(K2.LT.0) THEN
33140             K2 = -K2
33141             IF((K1.GT.I).OR.(K2.LT.I)) THEN
33142               WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33143      &          'inconsistent mother/daughter relation found',I,K1,K2
33144               CALL PHO_PREVNT(-1)
33145             ENDIF
33146             DO 400 II=K1+1,K2
33147               IF(ABS(ISTHEP(II)).LE.2) THEN
33148                 ICH1 = ICH1 + IPHO_CHR3(II,2)
33149                 IBA1 = IBA1 + IPHO_BAR3(II,2)
33150                 EE1 = EE1 + PHEP(4,II)
33151                 PX1 = PX1 + PHEP(1,II)
33152                 PY1 = PY1 + PHEP(2,II)
33153                 PZ1 = PZ1 + PHEP(3,II)
33154               ENDIF
33155  400        CONTINUE
33156           ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33157             ICH1 = ICH1 + IPHO_CHR3(K2,2)
33158             IBA1 = IBA1 + IPHO_BAR3(K2,2)
33159             EE1 = EE1 + PHEP(4,K2)
33160             PX1 = PX1 + PHEP(1,K2)
33161             PY1 = PY1 + PHEP(2,K2)
33162             PZ1 = PZ1 + PHEP(3,K2)
33163           ENDIF
33164
33165 C  sum over daughter particles
33166           ICH2 = 0.D0
33167           IBA2 = 0.D0
33168           EE2 = 0.D0
33169           PX2 = 0.D0
33170           PY2 = 0.D0
33171           PZ2 = 0.D0
33172           DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33173             IF(ABS(ISTHEP(II)).LE.2) THEN
33174               ICH2 = ICH2 + IPHO_CHR3(II,2)
33175               IBA2 = IBA2 + IPHO_BAR3(II,2)
33176               EE2 = EE2 + PHEP(4,II)
33177               PX2 = PX2 + PHEP(1,II)
33178               PY2 = PY2 + PHEP(2,II)
33179               PZ2 = PZ2 + PHEP(3,II)
33180             ENDIF
33181  200      CONTINUE
33182
33183 C  conservation check
33184           ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33185           IF(ABS(EE1-EE2).GT.ESC) THEN
33186             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33187      &        'PHO_CHECK: energy conservation violated for',
33188      &        'entry,initial,final:',I,EE1,EE2
33189             IDEV = 1
33190           ENDIF
33191           ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33192           IF(ABS(PX1-PX2).GT.ESC) THEN
33193             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33194      &        'PHO_CHECK: x-momentum conservation violated for',
33195      &        'entry,initial,final:',I,PX1,PX2
33196             IDEV = 1
33197           ENDIF
33198           ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33199           IF(ABS(PY1-PY2).GT.ESC) THEN
33200             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33201      &        'PHO_CHECK: y-momentum conservation violated for',
33202      &        'entry,initial,final:',I,PY1,PY2
33203             IDEV = 1
33204           ENDIF
33205           ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33206           IF(ABS(PZ1-PZ2).GT.ESC) THEN
33207             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33208      &        'PHO_CHECK: z-momentum conservation violated for',
33209      &        'entry,initial,final:',I,PZ1,PZ2
33210             IDEV = 1
33211           ENDIF
33212           IF(ICH1.NE.ICH2) THEN
33213             WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33214      &        'PHO_CHECK: charge conservation violated for',
33215      &        'entry,initial,final:',I,ICH1,ICH2
33216             IDEV = 1
33217           ENDIF
33218           IF(IBA1.NE.IBA2) THEN
33219             WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33220      &        'baryon charge conservation violated for',
33221      &        'entry,initial,final:',I,IBA1,IBA2
33222             IDEV = 1
33223           ENDIF
33224           IF(IDEB(20).GE.35) THEN
33225             WRITE(LO,
33226      &        '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33227      &      'PHO_CHECK diagnostics:',
33228      &      '(1.mother/l.mother,1.daughter/l.daughter):',
33229      &      K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33230      &      'mother momenta   ',PX1,PY1,PZ1,EE1,
33231      &      'daughter momenta ',PX2,PY2,PZ2,EE2,
33232      &      'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33233           ENDIF
33234         ENDIF
33235  99     CONTINUE
33236         I = I+1
33237       IF(I.LE.NHEP) GOTO 100
33238
33239  55   CONTINUE
33240
33241       IERR = IERR+IDEV
33242
33243 C  write complete event in case of deviations
33244       IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33245         CALL PHO_PREVNT(1)
33246         IF(ISTR.GT.0) THEN
33247           CALL PHO_PRSTRG
33248
33249           IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33250
33251         ENDIF
33252       ENDIF
33253
33254 C  stop after too many errors
33255       IF(IERR.GT.IPAMDL(179)) THEN
33256         WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33257      &    'too many inconsistencies found, program terminated',IERR
33258         CALL PHO_ABORT
33259       ENDIF
33260
33261       RETURN
33262
33263 C  overall check only (less time consuming)
33264
33265  500  CONTINUE
33266
33267       ICH2 = 0.D0
33268       IBA2 = 0.D0
33269       EE2 = 0.D0
33270       PX2 = 0.D0
33271       PY2 = 0.D0
33272       PZ2 = 0.D0
33273
33274       DO 300 K=3,NHEP
33275 C  recognize only existing particles as possible daughters
33276         IF(ABS(ISTHEP(K)).EQ.1) THEN
33277           ICH2 = ICH2 + IPHO_CHR3(K,2)
33278           IBA2 = IBA2 + IPHO_BAR3(K,2)
33279           EE2 = EE2 + PHEP(4,K)
33280           PX2 = PX2 + PHEP(1,K)
33281           PY2 = PY2 + PHEP(2,K)
33282           PZ2 = PZ2 + PHEP(3,K)
33283         ENDIF
33284  300  CONTINUE
33285
33286 C  check energy-momentum conservation
33287       ESC = ECM*DDREL
33288
33289       IF(IPAMDL(13).GT.0) THEN
33290
33291 C  DPMJET call with x limitations
33292         ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33293         IF(ABS(ECM1-ECM2).GT.ESC) THEN
33294           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33295      &      'PHO_CHECK: c.m. energy conservation violated',
33296      &      'initial/final energy:',ECM1,ECM2
33297           IDEV = 1
33298         ENDIF
33299
33300       ELSE
33301
33302 C  standard call
33303         IF(ABS(EE1-EE2).GT.ESC) THEN
33304           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33305      &      'PHO_CHECK: energy conservation violated',
33306      &      'initial/final energy:',EE1,EE2
33307           IDEV = 1
33308         ENDIF
33309         IF(ABS(PX1-PX2).GT.ESC) THEN
33310         WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33311      &      'PHO_CHECK: x-momentum conservation violated',
33312      &      'initial/final x-momentum:',PX1,PX2
33313           IDEV = 1
33314         ENDIF
33315         IF(ABS(PY1-PY2).GT.ESC) THEN
33316           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33317      &      'PHO_CHECK: y-momentum conservation violated',
33318      &      'initial/final y-momentum:',PY1,PY2
33319           IDEV = 1
33320         ENDIF
33321         IF(ABS(PZ1-PZ2).GT.ESC) THEN
33322           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33323      &      'PHO_CHECK: z-momentum conservation violated',
33324      &      'initial/final z-momentum:',PZ1,PZ2
33325           IDEV = 1
33326         ENDIF
33327
33328 C  check of quantum number conservation
33329
33330         ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33331         IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33332
33333         IF(ICH1.NE.ICH2) THEN
33334           WRITE(LO,'(1X,A,/,5X,A,2I5)')
33335      &      'PHO_CHECK: charge conservation violated',
33336      &      'initial/final charge sum',ICH1,ICH2
33337           IDEV = 1
33338         ENDIF
33339         IF(IBA1.NE.IBA2) THEN
33340           WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33341      &      'baryonic charge conservation violated',
33342      &      'initial/final baryonic charge sum',IBA1,IBA2
33343           IDEV = 1
33344         ENDIF
33345
33346       ENDIF
33347
33348 C  perform detailed checks in case of deviations
33349       IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33350         IF(IPAMDL(13).GT.0) THEN
33351           GOTO 55
33352         ELSE
33353           DDREL = DDREL/2.D0
33354           DDABS = DDABS/2.D0
33355           WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33356      &      'increasing precision of tests to',DDREL,DDABS
33357           GOTO 50
33358         ENDIF
33359       ENDIF
33360
33361       END
33362
33363 CDECK  ID>, PHO_ABORT
33364       SUBROUTINE PHO_ABORT
33365 C**********************************************************************
33366 C
33367 C     top MC event generation due to fatal error,
33368 C     print all information of event generation and history
33369 C
33370 C**********************************************************************
33371       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33372       SAVE
33373
33374 C  input/output channels
33375       INTEGER LI,LO
33376       COMMON /POINOU/ LI,LO
33377 C  event debugging information
33378       INTEGER NMAXD
33379       PARAMETER (NMAXD=100)
33380       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33381      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33382       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33383      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33384 C  model switches and parameters
33385       CHARACTER*8 MDLNA
33386       INTEGER ISWMDL,IPAMDL
33387       DOUBLE PRECISION PARMDL
33388       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33389
33390 C  standard particle data interface
33391       INTEGER NMXHEP
33392
33393       PARAMETER (NMXHEP=4000)
33394
33395       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33396       DOUBLE PRECISION PHEP,VHEP
33397       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33398      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33399      &                VHEP(4,NMXHEP)
33400 C  extension to standard particle data interface (PHOJET specific)
33401       INTEGER IMPART,IPHIST,ICOLOR
33402       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33403
33404 C  color string configurations including collapsed strings and hadrons
33405       INTEGER MSTR
33406       PARAMETER (MSTR=500)
33407       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33408       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33409      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33410      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33411 C  light-cone x fractions and c.m. momenta of soft cut string ends
33412       INTEGER MAXSOF
33413       PARAMETER ( MAXSOF = 50 )
33414       INTEGER IJSI2,IJSI1
33415       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33416       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33417      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33418      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
33419 C  hard scattering data
33420       INTEGER MSCAHD
33421       PARAMETER ( MSCAHD = 50 )
33422       INTEGER LSCAHD,LSC1HD,LSIDX,
33423      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33424       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33425       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33426      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33427      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33428      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33429      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33430      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33431      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33432
33433       WRITE(LO,'(//,1X,A,/,1X,A)')
33434      &  'PHO_ABORT: program execution stopped',
33435      &  '===================================='
33436       WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33437 C
33438       CALL PHO_SETMDL(0,0,-2)
33439       CALL PHO_PREVNT(-1)
33440       CALL PHO_ACTPDF(0,-2)
33441 C  print selected parton flavours
33442       WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33443       DO 700 I=1,KSOFT
33444         WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33445  700  CONTINUE
33446       WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33447       DO 750 K=1,KHARD
33448         I = LSIDX(K)
33449         WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33450         WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33451      &    NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33452  750  CONTINUE
33453 C  print selected parton momenta
33454       WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33455       DO 300 I=1,KSOFT
33456         WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33457         WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33458  300  CONTINUE
33459       WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33460       DO 350 K=1,KHARD
33461         I = LSIDX(K)
33462         I3 = 8*I-4
33463         WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33464         WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33465  350  CONTINUE
33466
33467 C  print /POEVT1/
33468       CALL PHO_PREVNT(0)
33469
33470 C  fragmentation process
33471       IF(ISTR.GT.0) THEN
33472 C  print /POSTRG/
33473         CALL PHO_PRSTRG
33474
33475         IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33476
33477       ENDIF
33478
33479 C  last message
33480       WRITE(LO,'(////5X,A,///5X,A,///)')
33481      &  'PHO_ABORT: execution terminated due to fatal error',
33482      &'*** Simulating division by zero to get traceback information ***'
33483       ISTR = 100/IPAMDL(100)
33484
33485       END
33486
33487 CDECK  ID>, PHO_TRACE
33488       SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33489 C**********************************************************************
33490 C
33491 C     trace program subroutines according to level,
33492 C                          original output levels will be saved
33493 C
33494 C     input:   ISTART      first event to trace
33495 C              ISWI        number of events to trace
33496 C                                0   loop call, use old values
33497 C                               -1   restore original output levels
33498 C                                1   store level and wait for event
33499 C              LEVEL       desired output level
33500 C                                0   standard output
33501 C                                3   internal rejections
33502 C                                5   cross sections, slopes etc.
33503 C                               10   parameter of subroutines and
33504 C                                    results
33505 C                               20   huge amount of debug output
33506 C                               30   maximal possible output
33507 C
33508 C**********************************************************************
33509       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33510       SAVE
33511
33512 C  input/output channels
33513       INTEGER LI,LO
33514       COMMON /POINOU/ LI,LO
33515 C  event debugging information
33516       INTEGER NMAXD
33517       PARAMETER (NMAXD=100)
33518       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33519      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33520       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33521      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33522
33523       DIMENSION IMEM(NMAXD)
33524
33525 C  protect ISWI
33526       ISW = ISWI
33527  10   CONTINUE
33528       IF(ISW.EQ.0) THEN
33529         IF(KEVENT.LT.ION) THEN
33530           RETURN
33531         ELSE IF(KEVENT.EQ.ION) THEN
33532           WRITE(LO,'(///,1X,A,///)')
33533      &      'PHO_TRACE: trace mode switched on'
33534           DO 100 I=1,NMAXD
33535             IMEM(I) = IDEB(I)
33536             IDEB(I) = MAX(ILEVEL,IMEM(I))
33537  100      CONTINUE
33538         ELSE IF(KEVENT.EQ.IOFF) THEN
33539           WRITE(LO,'(//,1X,A,///)')
33540      &      'PHO_TRACE: trace mode switched off'
33541           DO 200 I=1,NMAXD
33542             IDEB(I) = IMEM(I)
33543  200      CONTINUE
33544         ENDIF
33545       ELSE IF(ISW.EQ.-1) THEN
33546         DO 300 I=1,NMAXD
33547           IDEB(I) = IMEM(I)
33548  300    CONTINUE
33549       ELSE
33550 C  save information
33551         ION = ISTART
33552         IOFF = ISTART+ISW
33553         ILEVEL = LEVEL
33554       ENDIF
33555 C  check coincidence
33556       IF(ISW.GT.0) THEN
33557         ISW=0
33558         ILEVEL = LEVEL
33559         GOTO 10
33560       ENDIF
33561
33562       END
33563
33564 CDECK  ID>, PHO_PRSTRG
33565       SUBROUTINE PHO_PRSTRG
33566 C**********************************************************************
33567 C
33568 C     print information of /POSTRG/
33569 C
33570 C**********************************************************************
33571       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33572       SAVE
33573
33574 C  input/output channels
33575       INTEGER LI,LO
33576       COMMON /POINOU/ LI,LO
33577 C  event debugging information
33578       INTEGER NMAXD
33579       PARAMETER (NMAXD=100)
33580       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33581      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33582       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33583      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33584
33585 C  standard particle data interface
33586       INTEGER NMXHEP
33587
33588       PARAMETER (NMXHEP=4000)
33589
33590       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33591       DOUBLE PRECISION PHEP,VHEP
33592       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33593      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33594      &                VHEP(4,NMXHEP)
33595 C  extension to standard particle data interface (PHOJET specific)
33596       INTEGER IMPART,IPHIST,ICOLOR
33597       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33598
33599 C  color string configurations including collapsed strings and hadrons
33600       INTEGER MSTR
33601       PARAMETER (MSTR=500)
33602       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33603       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33604      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33605      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33606
33607       WRITE(LO,'(/,1X,A,I5)')
33608      &  'PHO_PRSTRG: number of strings soft+hard:',ISTR
33609       WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33610      &  ' NOBAM  ID1  ID2  ID3  ID4     NPO1/2/3/4        MASS'
33611       WRITE(LO,'(1X,A)')
33612      &  ' ======================================================='
33613       DO 800 I=1,ISTR
33614         WRITE(LO,'(1X,9I5,1P,E11.3)')
33615      &         NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33616      &         NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33617  800  CONTINUE
33618
33619       END
33620
33621 CDECK  ID>, PHO_PREVNT
33622       SUBROUTINE PHO_PREVNT(NPART)
33623 C**********************************************************************
33624 C
33625 C     print all information of event generation and history
33626 C
33627 C     input:        NPART  -1   minimal output: process IDs
33628 C                           0   additional output of /POEVT1/
33629 C                           1   additional output of /POSTRG/
33630 C                           2   additional output of /HEPEVT/
33631 C                               (call LULIST(1))
33632 C
33633 C**********************************************************************
33634       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33635       SAVE
33636
33637 C  input/output channels
33638       INTEGER LI,LO
33639       COMMON /POINOU/ LI,LO
33640 C  event debugging information
33641       INTEGER NMAXD
33642       PARAMETER (NMAXD=100)
33643       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33644      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33645       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33646      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33647 C  model switches and parameters
33648       CHARACTER*8 MDLNA
33649       INTEGER ISWMDL,IPAMDL
33650       DOUBLE PRECISION PARMDL
33651       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33652 C  global event kinematics and particle IDs
33653       INTEGER IFPAP,IFPAB
33654       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33655       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33656 C  general process information
33657       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33658       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33659
33660 C  standard particle data interface
33661       INTEGER NMXHEP
33662
33663       PARAMETER (NMXHEP=4000)
33664
33665       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33666       DOUBLE PRECISION PHEP,VHEP
33667       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33668      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33669      &                VHEP(4,NMXHEP)
33670 C  extension to standard particle data interface (PHOJET specific)
33671       INTEGER IMPART,IPHIST,ICOLOR
33672       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33673
33674 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
33675       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33676       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33677       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33678      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33679
33680       CHARACTER*15 PHO_PNAME
33681
33682       IF(NPART.GE.0) WRITE(LO,'(/)')
33683       WRITE(LO,'(1X,A,1PE10.3)')
33684      &  'PHO_PREVNT: c.m. energy',ECM
33685       CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33686       WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33687      &  'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33688      &  'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33689      &  KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33690      &  KHDPO
33691       WRITE(LO,'(6X,A,I4,4I3)')
33692      &  'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33693      &  IDIFR2,IDDPOM
33694
33695       IF(IPAMDL(13).GT.0) THEN
33696         WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33697         WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33698      &    ECMN,PCMN,SECM,SPCM
33699         WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33700       ENDIF
33701
33702       IF(NPART.LT.0) RETURN
33703
33704       IF(NPART.GE.1) CALL PHO_PRSTRG
33705
33706       WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33707       ICHAS  = 0
33708       IBARFS = 0
33709       IMULC  = 0
33710       IMUL   = 0
33711       WRITE(LO,'(/1X,A,A,/,1X,A,A)')
33712      &  '   NO  IST    NAME         MO-1 MO-2 DA-1 DA-2  CHA  BAR',
33713      &  '  IH1  IH2  CO1  CO2',
33714      &  '========================================================',
33715      &  '===================='
33716       DO 20 IH=1,NHEP
33717         CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
33718         BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
33719         WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
33720      &    IH,ISTHEP(IH),PHO_PNAME(IH,2),
33721      &    JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
33722      &    CH,BA,IPHIST(1,IH),IPHIST(2,IH),
33723      &    ICOLOR(1,IH),ICOLOR(2,IH)
33724         IF(ABS(ISTHEP(IH)).EQ.1) THEN
33725           ICHAS  = ICHAS  + IPHO_CHR3(IH,2)
33726           IBARFS = IBARFS + IPHO_BAR3(IH,2)
33727         ENDIF
33728         IF(ABS(ISTHEP(IH)).EQ.1) THEN
33729           IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
33730           IMUL = IMUL+1
33731         ENDIF
33732    20 CONTINUE
33733       WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
33734      &  'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
33735
33736       WRITE(LO,7)
33737       PXS    = 0.D0
33738       PYS    = 0.D0
33739       PZS    = 0.D0
33740       P0S    = 0.D0
33741       DO 30 IN=1,NHEP
33742         IF(     (ABS(PHEP(3,IN)).LT.99999.D0)
33743      &     .AND.(PHEP(4,IN).LT.99999.D0)) THEN
33744           WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33745      &      (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33746         ELSE
33747           WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33748      &      (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33749         ENDIF
33750         IF(ABS(ISTHEP(IN)).EQ.1) THEN
33751           PXS = PXS + PHEP(1,IN)
33752           PYS = PYS + PHEP(2,IN)
33753           PZS = PZS + PHEP(3,IN)
33754           P0S = P0S + PHEP(4,IN)
33755         ENDIF
33756    30 CONTINUE
33757       AMFS = P0S**2-PXS**2-PYS**2-PZS**2
33758       AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
33759       IF(P0S.LT.99999.D0) THEN
33760         WRITE(LO,10) '      sum:    ',PXS,PYS,PZS,P0S,AMFS
33761       ELSE
33762         WRITE(LO,12) '      sum:    ',PXS,PYS,PZS,P0S,AMFS
33763       ENDIF
33764       WRITE(LO,'(//)')
33765
33766     5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
33767      &  8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
33768      &  8H CHARGE ,8H BARYON ,/)
33769     6 FORMAT(7I8,2F8.3)
33770     7 FORMAT(/,2X,' NR STAT NAME        X-MOMENTA',
33771      &  ' Y-MOMENTA Z-MOMENTA  ENERGY    MASS     PT',/,
33772      &         2X,'-------------------------------',
33773      &  '--------------------------------------------')
33774     8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
33775     9 FORMAT(I10,14X,5F10.3)
33776    10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
33777    11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
33778    12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
33779
33780       IF(NPART.GE.2) CALL PYLIST(1)
33781
33782       END
33783
33784 CDECK  ID>, PHO_LTRHEP
33785       SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
33786 C*******************************************************************
33787 C
33788 C     Lorentz transformation of entries I1 to I2 in /POEVT1/
33789 C
33790 C********************************************************************
33791       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33792       SAVE
33793
33794       PARAMETER ( DIFF = 0.001D0,
33795      &            EPS  = 1.D-5 )
33796
33797 C  input/output channels
33798       INTEGER LI,LO
33799       COMMON /POINOU/ LI,LO
33800 C  event debugging information
33801       INTEGER NMAXD
33802       PARAMETER (NMAXD=100)
33803       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33804      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33805       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33806      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33807
33808 C  standard particle data interface
33809       INTEGER NMXHEP
33810
33811       PARAMETER (NMXHEP=4000)
33812
33813       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33814       DOUBLE PRECISION PHEP,VHEP
33815       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33816      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33817      &                VHEP(4,NMXHEP)
33818 C  extension to standard particle data interface (PHOJET specific)
33819       INTEGER IMPART,IPHIST,ICOLOR
33820       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33821
33822       DO 100 I=I1,MIN(I2,NHEP)
33823         IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
33824           CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33825      &      XX,YY,ZZ)
33826           EE=PHEP(4,I)
33827           CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33828      &      PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
33829         ELSE IF(ISTHEP(I).EQ.20) THEN
33830           EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
33831           CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33832      &      XX,YY,ZZ)
33833           CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33834      &      PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
33835         ENDIF
33836  100  CONTINUE
33837
33838 C  debug precision
33839       IF(IDEB(70).LT.1) RETURN
33840       DO 200 I=I1,MIN(NHEP,I2)
33841         IF(ABS(ISTHEP(I)).GT.10) GOTO 190
33842         PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
33843         PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
33844         IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
33845           WRITE(LO,'(1X,A,I5,2E13.4)')
33846      &      'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
33847         ENDIF
33848  190    CONTINUE
33849  200  CONTINUE
33850
33851       END
33852
33853 CDECK  ID>, PHO_PECMS
33854       SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
33855 C*******************************************************************
33856 C
33857 C     calculation of cms momentum and energy of massive particle
33858 C     (ID=  1 using PMASS1,  2 using PMASS2)
33859 C
33860 C     output:  PP    cms momentum
33861 C              EE    energy in CMS of particle ID
33862 C
33863 C********************************************************************
33864       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33865       SAVE
33866
33867 C  input/output channels
33868       INTEGER LI,LO
33869       COMMON /POINOU/ LI,LO
33870 C  event debugging information
33871       INTEGER NMAXD
33872       PARAMETER (NMAXD=100)
33873       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33874      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33875       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33876      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33877 C  some constants
33878       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
33879       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
33880      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
33881
33882       S=ECM**2
33883       PM1 = SIGN(PMASS1**2,PMASS1)
33884       PM2 = SIGN(PMASS2**2,PMASS2)
33885       PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
33886      &          + PM1**2 + PM2**2)/(2.D0*ECM)
33887
33888       IF(ID.EQ.1) THEN
33889         EE = SQRT( PM1 + PP**2 )
33890       ELSE IF(ID.EQ.2) THEN
33891         EE = SQRT( PM2 + PP**2 )
33892       ELSE
33893         WRITE(LO,'(/1X,A,I3,/)')
33894      &    'PHO_PECMS:ERROR: invalid ID number:',ID
33895         EE = PP
33896       ENDIF
33897
33898       END
33899
33900 CDECK  ID>, PHO_FRAINI
33901       SUBROUTINE PHO_FRAINI(IDEFAU)
33902 C***********************************************************************
33903 C
33904 C     initialization of fragmentation packages
33905 C      (currently LUND JETSET)
33906 C
33907 C     initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
33908 C                      changed to work in PHOJET   (R.E. 1/94)
33909 C
33910 C     input:  IDEFAU    0  no hadronization at all
33911 C                       1  do not touch any parameter of JETSET
33912 C                       2  default parameters kept, decay length 10mm to
33913 C                          define stable particles
33914 C                       3  load tuned parameters for JETSET 7.3
33915 C             neg. value:  prevent strange/charm hadrons from decaying
33916 C
33917 C***********************************************************************
33918       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33919       SAVE
33920
33921       PARAMETER (EPS=1.D-10)
33922
33923 C  input/output channels
33924       INTEGER LI,LO
33925       COMMON /POINOU/ LI,LO
33926
33927       INTEGER N,NPAD,K
33928       DOUBLE PRECISION P,V
33929       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33930
33931       INTEGER MSTU,MSTJ
33932       DOUBLE PRECISION PARU,PARJ
33933       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33934
33935       INTEGER KCHG
33936       DOUBLE PRECISION  PMAS,PARF,VCKM
33937       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33938
33939       INTEGER MDCY,MDME,KFDP
33940       DOUBLE PRECISION  BRAT
33941       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
33942
33943       INTEGER PYCOMP
33944
33945       IDEFAB = ABS(IDEFAU)
33946
33947       IF(IDEFAB.EQ.0) THEN
33948         WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
33949         RETURN
33950       ENDIF
33951 C  defaults
33952       DEF2  = PARJ(2)
33953       IDEF12 = MSTJ(12)
33954       DEF19 = PARJ(19)
33955       DEF41 = PARJ(41)
33956       DEF42 = PARJ(42)
33957       DEF21 = PARJ(21)
33958
33959 C  declare stable particles
33960       IF(IDEFAB.GE.2) MSTJ(22) = 2
33961
33962 C  load optimized parameters
33963       IF(IDEFAB.GE.3) THEN
33964
33965 *       PARJ(19)=0.19
33966 C  Lund a-parameter
33967 C  (default=0.3)
33968         PARJ(41)=0.3
33969 C  Lund b-parameter
33970 C  (default=1.0)
33971         PARJ(42)=1.0
33972 C  Lund sigma parameter in pt distribution
33973 C  (default=0.36)
33974         PARJ(21)=0.36
33975       ENDIF
33976 C
33977 C  prevent particles decaying
33978       IF(IDEFAU.LT.0) THEN
33979 C                 K0S
33980
33981         KC=PYCOMP(310)
33982
33983         MDCY(KC,1)=0
33984 C                 PI0
33985
33986         KC=PYCOMP(111)
33987
33988         MDCY(KC,1)=0
33989 C                 LAMBDA
33990
33991         KC=PYCOMP(3122)
33992
33993         MDCY(KC,1)=0
33994 C                 ALAMBDA
33995
33996         KC=PYCOMP(-3122)
33997
33998         MDCY(KC,1)=0
33999 C                 SIG+
34000
34001         KC=PYCOMP(3222)
34002
34003         MDCY(KC,1)=0
34004 C                 ASIG+
34005
34006         KC=PYCOMP(-3222)
34007
34008         MDCY(KC,1)=0
34009 C                 SIG-
34010
34011         KC=PYCOMP(3112)
34012
34013         MDCY(KC,1)=0
34014 C                 ASIG-
34015
34016         KC=PYCOMP(-3112)
34017
34018         MDCY(KC,1)=0
34019 C                 SIG0
34020
34021         KC=PYCOMP(3212)
34022
34023         MDCY(KC,1)=0
34024 C                 ASIG0
34025
34026         KC=PYCOMP(-3212)
34027
34028         MDCY(KC,1)=0
34029 C                 TET0
34030
34031         KC=PYCOMP(3322)
34032
34033         MDCY(KC,1)=0
34034 C                 ATET0
34035
34036         KC=PYCOMP(-3322)
34037
34038         MDCY(KC,1)=0
34039 C                 TET-
34040
34041         KC=PYCOMP(3312)
34042
34043         MDCY(KC,1)=0
34044 C                 ATET-
34045
34046         KC=PYCOMP(-3312)
34047
34048         MDCY(KC,1)=0
34049 C                 OMEGA-
34050
34051         KC=PYCOMP(3334)
34052
34053         MDCY(KC,1)=0
34054 C                 AOMEGA-
34055
34056         KC=PYCOMP(-3334)
34057
34058         MDCY(KC,1)=0
34059 C                 D+
34060
34061         KC=PYCOMP(411)
34062
34063         MDCY(KC,1)=0
34064 C                 D-
34065
34066         KC=PYCOMP(-411)
34067
34068         MDCY(KC,1)=0
34069 C                 D0
34070
34071         KC=PYCOMP(421)
34072
34073         MDCY(KC,1)=0
34074 C                 A-D0
34075
34076         KC=PYCOMP(-421)
34077
34078         MDCY(KC,1)=0
34079 C                 DS+
34080
34081         KC=PYCOMP(431)
34082
34083         MDCY(KC,1)=0
34084 C                 A-DS+
34085
34086         KC=PYCOMP(-431)
34087
34088         MDCY(KC,1)=0
34089 C                ETAC
34090
34091         KC=PYCOMP(441)
34092
34093         MDCY(KC,1)=0
34094 C                LAMBDAC+
34095
34096         KC=PYCOMP(4122)
34097
34098         MDCY(KC,1)=0
34099 C                A-LAMBDAC+
34100
34101         KC=PYCOMP(-4122)
34102
34103         MDCY(KC,1)=0
34104 C                SIGMAC++
34105
34106         KC=PYCOMP(4222)
34107
34108         MDCY(KC,1)=0
34109 C                SIGMAC+
34110
34111         KC=PYCOMP(4212)
34112
34113         MDCY(KC,1)=0
34114 C                SIGMAC0
34115
34116         KC=PYCOMP(4112)
34117
34118         MDCY(KC,1)=0
34119 C                A-SIGMAC++
34120
34121         KC=PYCOMP(-4222)
34122
34123         MDCY(KC,1)=0
34124 C                A-SIGMAC+
34125
34126         KC=PYCOMP(-4212)
34127
34128         MDCY(KC,1)=0
34129 C                A-SIGMAC0
34130
34131         KC=PYCOMP(-4112)
34132
34133         MDCY(KC,1)=0
34134 C                KSIC+
34135
34136         KC=PYCOMP(4232)
34137
34138         MDCY(KC,1)=0
34139 C                KSIC0
34140
34141         KC=PYCOMP(4132)
34142
34143         MDCY(KC,1)=0
34144 C                A-KSIC+
34145
34146         KC=PYCOMP(-4232)
34147
34148         MDCY(KC,1)=0
34149 C                A-KSIC0
34150
34151         KC=PYCOMP(-4132)
34152
34153         MDCY(KC,1)=0
34154       ENDIF
34155
34156 C *** Commented by Chiara
34157 C      WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34158 C     &  DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34159 C 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34160 C     &        ' --------------------------------------------------',/,
34161 C     & 5X,'parameter description               default / current',/,
34162 C     & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34163 C     & 5X,'MSTJ(12) popcorn                 : ',2I7,/,
34164 C     & 5X,'PARJ(19) popcorn                 : ',2F7.3,/,
34165 C     & 5X,'PARJ(41) Lund a                  : ',2F7.3,/,
34166 C     & 5X,'PARJ(42) Lund b                  : ',2F7.3,/,
34167 C     & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34168
34169       END
34170
34171 CDECK  ID>, PHO_SETPAR
34172       SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34173 C**********************************************************************
34174 C
34175 C     assign a particle to either side 1 or 2
34176 C     (including special treatment for remnants)
34177 C
34178 C     input:    Iside      1,2  side selected for the particle
34179 C                          -2   output of current settings
34180 C               IDpdg      PDG number
34181 C               IDcpc      CPC number
34182 C                          0     CPC determination in subroutine
34183 C                          -1    special particle remnant, IDPDG
34184 C                                is the particle number the remnant
34185 C                                corresponds to (see /POHDFL/)
34186 C
34187 C**********************************************************************
34188
34189       IMPLICIT NONE
34190
34191       SAVE
34192
34193       integer Iside,IDpdg,IDcpc
34194       double precision Pvir
34195
34196 C  input/output channels
34197       INTEGER LI,LO
34198       COMMON /POINOU/ LI,LO
34199 C  event debugging information
34200       INTEGER NMAXD
34201       PARAMETER (NMAXD=100)
34202       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34203      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34204       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34205      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34206 C  global event kinematics and particle IDs
34207       INTEGER IFPAP,IFPAB
34208       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34209       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34210 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
34211       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34212       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34213       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34214      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34215 C  particle ID translation table
34216       integer         ID_pdg_list,ID_list,ID_pdg_max
34217       character*12    name_list
34218       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34219      &                ID_pdg_max
34220 C  general particle data
34221       double precision xm_list,tau_list,gam_list,
34222      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34223      &  xm_bb82_list,xm_bb102_list
34224       integer          ich3_list,iba3_list,iq_list,
34225      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
34226       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34227      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
34228      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34229      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34230      &  ich3_list(300),iba3_list(300),iq_list(3,300),
34231      &  id_psm_list(6,6),id_vem_list(6,6),
34232      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
34233 C  particle decay data
34234       double precision wg_sec_list
34235       integer          idec_list,isec_list
34236       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34237      &  isec_list(3,500)
34238
34239 C  external functions
34240       integer ipho_pdg2id,ipho_chr3,ipho_bar3
34241       double precision pho_pmass
34242
34243 C  local variables
34244       integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34245
34246       IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34247         IDcpcN = IDcpc
34248 C  remnant?
34249         IF(IDcpc.EQ.-1) THEN
34250           IF(Iside.EQ.1) THEN
34251             IDpdgR = 81
34252           ELSE
34253             IDpdgR = 82
34254           ENDIF
34255           IDcpcR = ipho_pdg2id(IDpdgR)
34256           IDEQB(Iside) = ipho_pdg2id(IDpdg)
34257           IDEQP(Iside) = IDpdg
34258 C  copy particle properties
34259           IDB = abs(IDEQB(Iside))
34260           xm_list(IDcpcR)  = xm_list(IDB)
34261           tau_list(IDcpcR) = tau_list(IDB)
34262           gam_list(IDcpcR) = gam_list(IDB)
34263           IF(IHFLS(Iside).EQ.1) THEN
34264             ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34265             iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34266           ELSE
34267             ich3_list(IDcpcR) = 0
34268             iba3_list(IDcpcR) = 0
34269           ENDIF
34270 C  quark content
34271           IFL1 = IHFLD(Iside,1)
34272           IFL2 = IHFLD(Iside,2)
34273           IFL3 = 0
34274           IF(IHFLS(Iside).EQ.1) THEN
34275             IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34276               IFL1 = IHFLD(Iside,1)/1000
34277               IFL2 = MOD(IHFLD(Iside,1)/100,10)
34278               IFL3 = IHFLD(Iside,2)
34279             ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34280               IFL1 = IHFLD(Iside,1)
34281               IFL2 = IHFLD(Iside,2)/1000
34282               IFL3 = MOD(IHFLD(Iside,2)/100,10)
34283             ENDIF
34284           ENDIF
34285           iq_list(1,IDcpcR) = IFL1
34286           iq_list(2,IDcpcR) = IFL2
34287           iq_list(3,IDcpcR) = IFL3
34288
34289           IDcpcN = IDcpcR
34290           IDPDGN = IDPDGR
34291
34292           IF(IDEB(87).GE.5) THEN
34293             WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34294      &        'pho_setpar: remnant assignment side',Iside,
34295      &        'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34296           ENDIF
34297         ELSE IF(IDcpc.EQ.0) THEN
34298 C  ordinary hadron
34299           IHFLS(Iside) = 1
34300           IHFLD(Iside,1) = 0
34301           IHFLD(Iside,2) = 0
34302           IDcpcN = ipho_pdg2id(IDpdg)
34303           IDpdgN = IDpdg
34304         ENDIF
34305
34306 C initialize /POGCMS/
34307         IFPAP(Iside) = IDpdgN
34308         IFPAB(Iside) = IDcpcN
34309         PMASS(Iside) = pho_pmass(IDcpcN,0)
34310         IF(IFPAP(Iside).EQ.22) THEN
34311           PVIRT(Iside) = ABS(PVIR)
34312         ELSE
34313           PVIRT(Iside) = 0.D0
34314         ENDIF
34315
34316       ELSE IF(Iside.EQ.-2) THEN
34317 C  output of current settings
34318         DO 100 I=1,2
34319           WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34320      &      'PHO_SETPAR: side',
34321      &      I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34322      &      PVIRT(I)
34323           IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34324             WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34325      &        'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34326      &        IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34327           ENDIF
34328  100    CONTINUE
34329       ELSE
34330         WRITE(LO,'(/1X,A,I8)')
34331      &    'pho_setpar: invalid argument (Iside)',Iside
34332       ENDIF
34333
34334       END
34335
34336 CDECK  ID>, PHO_XLAM
34337       DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34338 C**********************************************************************
34339 C
34340 C     auxiliary function for two/three particle decay mode
34341 C     (standard LAMBDA**(1/2) function)
34342 C
34343 C**********************************************************************
34344       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34345       SAVE
34346 C
34347       YZ=Y-Z
34348       XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34349       IF(XLAM.LT.0.D0) XLAM=-XLAM
34350       PHO_XLAM=SQRT(XLAM)
34351       END
34352
34353 CDECK  ID>, PHO_BESSJ0
34354       DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34355 C**********************************************************************
34356 C
34357 C     CERN (KERN) LIB function C312
34358 C
34359 C     modified by R. Engel (03/02/93)
34360 C
34361 C**********************************************************************
34362       DOUBLE PRECISION DX
34363       DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34364       DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34365       SAVE
34366
34367       DATA EIGHT /8.0D0/
34368       DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34369
34370       DATA C1( 0) /+0.15772 79714 7489D0/
34371       DATA C1( 1) /-0.00872 34423 5285D0/
34372       DATA C1( 2) /+0.26517 86132 0334D0/
34373       DATA C1( 3) /-0.37009 49938 7265D0/
34374       DATA C1( 4) /+0.15806 71023 3210D0/
34375       DATA C1( 5) /-0.03489 37694 1141D0/
34376       DATA C1( 6) /+0.00481 91800 6947D0/
34377       DATA C1( 7) /-0.00046 06261 6621D0/
34378       DATA C1( 8) /+0.00003 24603 2882D0/
34379       DATA C1( 9) /-0.00000 17619 4691D0/
34380       DATA C1(10) /+0.00000 00760 8164D0/
34381       DATA C1(11) /-0.00000 00026 7925D0/
34382       DATA C1(12) /+0.00000 00000 7849D0/
34383       DATA C1(13) /-0.00000 00000 0194D0/
34384       DATA C1(14) /+0.00000 00000 0004D0/
34385
34386       DATA C2( 0) /+0.99946 03493 4752D0/
34387       DATA C2( 1) /-0.00053 65220 4681D0/
34388       DATA C2( 2) /+0.00000 30751 8479D0/
34389       DATA C2( 3) /-0.00000 00517 0595D0/
34390       DATA C2( 4) /+0.00000 00016 3065D0/
34391       DATA C2( 5) /-0.00000 00000 7864D0/
34392       DATA C2( 6) /+0.00000 00000 0517D0/
34393       DATA C2( 7) /-0.00000 00000 0043D0/
34394       DATA C2( 8) /+0.00000 00000 0004D0/
34395       DATA C2( 9) /-0.00000 00000 0001D0/
34396
34397       DATA C3( 0) /-0.01555 58546 05337D0/
34398       DATA C3( 1) /+0.00006 83851 99426D0/
34399       DATA C3( 2) /-0.00000 07414 49841D0/
34400       DATA C3( 3) /+0.00000 00179 72457D0/
34401       DATA C3( 4) /-0.00000 00007 27192D0/
34402       DATA C3( 5) /+0.00000 00000 42201D0/
34403       DATA C3( 6) /-0.00000 00000 03207D0/
34404       DATA C3( 7) /+0.00000 00000 00301D0/
34405       DATA C3( 8) /-0.00000 00000 00033D0/
34406       DATA C3( 9) /+0.00000 00000 00004D0/
34407       DATA C3(10) /-0.00000 00000 00001D0/
34408
34409       X=DX
34410       V=ABS(X)
34411       IF(V .LT. EIGHT) THEN
34412        Y=V/EIGHT
34413        H=2.D0*Y**2-1.D0
34414        ALFA=-2.D0*H
34415        B1=0.D0
34416        B2=0.D0
34417        DO 1 I = 14,0,-1
34418        B0=C1(I)-ALFA*B1-B2
34419        B2=B1
34420     1  B1=B0
34421        B1=B0-H*B2
34422       ELSE
34423        R=1.D0/V
34424        Y=EIGHT*R
34425        H=2.D0*Y**2-1.D0
34426        ALFA=-2.D0*H
34427        B1=0.D0
34428        B2=0.D0
34429        DO 2 I = 9,0,-1
34430        B0=C2(I)-ALFA*B1-B2
34431        B2=B1
34432     2  B1=B0
34433        P=B0-H*B2
34434        B1=0.D0
34435        B2=0.D0
34436        DO 3 I = 10,0,-1
34437        B0=C3(I)-ALFA*B1-B2
34438        B2=B1
34439     3  B1=B0
34440        Q=Y*(B0-H*B2)
34441        B0=V-PI2
34442        B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34443       ENDIF
34444       PHO_BESSJ0=B1
34445       RETURN
34446       END
34447
34448 CDECK  ID>, PHO_BESSI0
34449       DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34450 C**********************************************************************
34451 C
34452 C      Bessel Function I0
34453 C
34454 C**********************************************************************
34455       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34456       SAVE
34457
34458       AX = ABS(X)
34459       IF (AX .LT. 3.75D0) THEN
34460         Y = (X/3.75D0)**2
34461         PHO_BESSI0 =
34462      &    1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34463      &    +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34464       ELSE
34465         Y = 3.75D0/AX
34466         PHO_BESSI0 =
34467      &    (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34468      &    +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34469      &    +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34470      &    +Y*0.392377D-2))))))))
34471       ENDIF
34472
34473       END
34474
34475 CDECK  ID>, PHO_BESSI1
34476       DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34477 C**********************************************************************
34478 C
34479 C      Bessel Function I1
34480 C
34481 C**********************************************************************
34482       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34483       SAVE
34484
34485       AX = ABS(X)
34486
34487       IF (AX .LT. 3.75D0) THEN
34488         Y = (X/3.75D0)**2
34489         BESLI1 =
34490      &    AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34491      &    +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34492       ELSE
34493         Y = 3.75D0/AX
34494         BESLI1 =
34495      &    0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34496      &    -Y*0.420059D-2))
34497         BESLI1 =
34498      &    0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34499      &    +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34500         BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34501       ENDIF
34502       IF (X .LT. 0.D0) BESLI1 = -BESLI1
34503
34504       PHO_BESSI1 = BESLI1
34505
34506       END
34507
34508 CDECK  ID>, PHO_BESSK0
34509       DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34510 C**********************************************************************
34511 C
34512 C      Modified Bessel Function K0
34513 C
34514 C**********************************************************************
34515       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34516       SAVE
34517
34518       IF (X .LT. 2.D0) THEN
34519         Y = X**2/4.D0
34520         PHO_BESSK0 =
34521      &    (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34522      &    +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34523      &    +Y*(0.10750D-3+Y*0.740D-5))))))
34524       ELSE
34525         Y = 2.D0/X
34526         PHO_BESSK0 =
34527      &    (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34528      &    +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34529      &    +Y*(-0.251540D-2+Y*0.53208D-3))))))
34530       ENDIF
34531
34532       END
34533
34534 CDECK  ID>, PHO_BESSK1
34535       DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34536 C**********************************************************************
34537 C
34538 C      Modified Bessel Function K1
34539 C
34540 C**********************************************************************
34541       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34542       SAVE
34543
34544       IF (X .LT. 2.D0) THEN
34545         Y = X**2/4.D0
34546         PHO_BESSK1 =
34547      &    (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34548      &    +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34549      &    +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34550       ELSE
34551         Y=2.D0/X
34552         PHO_BESSK1 =
34553      &    (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34554      &    +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34555      &    +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34556       ENDIF
34557
34558       END
34559
34560 CDECK  ID>, PHO_GAUSET
34561       SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34562 C********************************************************************
34563 C
34564 C     N-point gauss zeros and weights for the interval (AX,BX) are
34565 C           stored in  arrays Z and W respectively.
34566 C
34567 C*********************************************************************
34568       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34569       SAVE
34570
34571       COMMON /POGDAT/A(273),X(273),KTAB(96)
34572       DIMENSION Z(NX),W(NX)
34573
34574       ALPHA=0.5*(BX+AX)
34575       BETA=0.5*(BX-AX)
34576       N=NX
34577
34578 C  the N=1 case:
34579       IF(N.NE.1) GO TO 1
34580       Z(1)=ALPHA
34581       W(1)=BX-AX
34582       RETURN
34583
34584 C  the Gauss cases:
34585     1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34586       IF(N.EQ.20) GO TO 2
34587       IF(N.EQ.24) GO TO 2
34588       IF(N.EQ.32) GO TO 2
34589       IF(N.EQ.40) GO TO 2
34590       IF(N.EQ.48) GO TO 2
34591       IF(N.EQ.64) GO TO 2
34592       IF(N.EQ.80) GO TO 2
34593       IF(N.EQ.96) GO TO 2
34594
34595 C  the extended Gauss cases:
34596       IF((N/96)*96.EQ.N) GO TO 3
34597
34598 C  jump to center of intervall intrgration:
34599       GO TO 100
34600
34601 C  get Gauss point array
34602
34603     2 CALL PHO_GAUDAT
34604 C  extract real points
34605       K=KTAB(N)
34606       M=N/2
34607       DO 21 J=1,M
34608 C       extract values from big array
34609         JTAB=K-1+J
34610         WTEMP=BETA*A(JTAB)
34611         DELTA=BETA*X(JTAB)
34612 C       store them backward
34613         Z(J)=ALPHA-DELTA
34614         W(J)=WTEMP
34615 C       store them forward
34616         JP=N+1-J
34617         Z(JP)=ALPHA+DELTA
34618         W(JP)=WTEMP
34619    21 CONTINUE
34620 C     store central point (odd N)
34621       IF((N-M-M).EQ.0) RETURN
34622       Z(M+1)=ALPHA
34623       JMID=K+M
34624       W(M+1)=BETA*A(JMID)
34625       RETURN
34626
34627 C  get ND96 times chained 96 Gauss point array
34628
34629     3 CALL PHO_GAUDAT
34630 C  print out message
34631 C     -extract real points
34632       K=KTAB(96)
34633       ND96=N/96
34634       DO 31 J=1,48
34635 C       extract values from big array
34636         JTAB=K-1+J
34637         WTEMP=BETA*A(JTAB)
34638         DELTA=BETA*X(JTAB)
34639         WTeMP=WTEMP/ND96
34640         DeLTA=DELTA/ND96
34641         DO 32 JD96=0,ND96-1
34642           ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34643 C         store them backward
34644           Z(J+JD96*96)=ZCNTR-DELTA
34645           W(J+JD96*96)=WTEMP
34646 C         store them forward
34647           JP=96+1-J
34648           Z(JP+JD96*96)=ZCNTR+DELTA
34649           W(JP+JD96*96)=WTEMP
34650    32   CONTINUE
34651    31 CONTINUE
34652       RETURN
34653
34654 C  the center of intervall cases:
34655   100 CONTINUE
34656 C  put in constant weight and equally spaced central points
34657       N=IABS(N)
34658       DO 111 IN=1,N
34659         WIN=(BX-AX)/FLOAT(N)
34660         Z(IN)=AX  + (FLOAT(IN)-.5)*WIN
34661   111 W(IN)=WIN
34662
34663       END
34664
34665 CDECK  ID>, PHO_GAUDAT
34666       SUBROUTINE PHO_GAUDAT
34667 C*********************************************************************
34668 C
34669 C     store big arrays needed for Gauss integral, CERNLIB D106BD
34670 C     (arrays A,X,ITAB copied on B,Y,LTAB)
34671 C
34672 C*********************************************************************
34673       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34674
34675       SAVE
34676       COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34677       DIMENSION       A(273),X(273),KTAB(96)
34678
34679 C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34680       DATA KTAB(2)/1/
34681       DATA KTAB(3)/2/
34682       DATA KTAB(4)/4/
34683       DATA KTAB(5)/6/
34684       DATA KTAB(6)/9/
34685       DATA KTAB(7)/12/
34686       DATA KTAB(8)/16/
34687       DATA KTAB(9)/20/
34688       DATA KTAB(10)/25/
34689       DATA KTAB(11)/30/
34690       DATA KTAB(12)/36/
34691       DATA KTAB(13)/42/
34692       DATA KTAB(14)/49/
34693       DATA KTAB(15)/56/
34694       DATA KTAB(16)/64/
34695       DATA KTAB(20)/72/
34696       DATA KTAB(24)/82/
34697       DATA KTAB(28)/82/
34698       DATA KTAB(32)/94/
34699       DATA KTAB(36)/94/
34700       DATA KTAB(40)/110/
34701       DATA KTAB(44)/110/
34702       DATA KTAB(48)/130/
34703       DATA KTAB(52)/130/
34704       DATA KTAB(56)/130/
34705       DATA KTAB(60)/130/
34706       DATA KTAB(64)/154/
34707       DATA KTAB(68)/154/
34708       DATA KTAB(72)/154/
34709       DATA KTAB(76)/154/
34710       DATA KTAB(80)/186/
34711       DATA KTAB(84)/186/
34712       DATA KTAB(88)/186/
34713       DATA KTAB(92)/186/
34714       DATA KTAB(96)/226/
34715 C
34716 C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
34717 C
34718 C-----N=2
34719       DATA X(1)/0.577350269189626D0  /, A(1)/1.000000000000000D0  /
34720 C-----N=3
34721       DATA X(2)/0.774596669241483D0  /, A(2)/0.555555555555556D0  /
34722       DATA X(3)/0.000000000000000D0  /, A(3)/0.888888888888889D0  /
34723 C-----N=4
34724       DATA X(4)/0.861136311594053D0  /, A(4)/0.347854845137454D0  /
34725       DATA X(5)/0.339981043584856D0  /, A(5)/0.652145154862546D0  /
34726 C-----N=5
34727       DATA X(6)/0.906179845938664D0  /, A(6)/0.236926885056189D0  /
34728       DATA X(7)/0.538469310105683D0  /, A(7)/0.478628670499366D0  /
34729       DATA X(8)/0.000000000000000D0  /, A(8)/0.568888888888889D0  /
34730 C-----N=6
34731       DATA X(9)/0.932469514203152D0  /, A(9)/0.171324492379170D0  /
34732       DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
34733       DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
34734 C-----N=7
34735       DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
34736       DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
34737       DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
34738       DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
34739 C-----N=8
34740       DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
34741       DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
34742       DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
34743       DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
34744 C-----N=9
34745       DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
34746       DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
34747       DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
34748       DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
34749       DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
34750 C-----N=10
34751       DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
34752       DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
34753       DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
34754       DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
34755       DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
34756 C-----N=11
34757       DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
34758       DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
34759       DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
34760       DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
34761       DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
34762       DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
34763 C-----N=12
34764       DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
34765       DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
34766       DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
34767       DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
34768       DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
34769       DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
34770 C-----N=13
34771       DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
34772       DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
34773       DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
34774       DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
34775       DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
34776       DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
34777       DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
34778 C-----N=14
34779       DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
34780       DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
34781       DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
34782       DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
34783       DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
34784       DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
34785       DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
34786 C-----N=15
34787       DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
34788       DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
34789       DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
34790       DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
34791       DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
34792       DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
34793       DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
34794       DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
34795 C-----N=16
34796       DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
34797       DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
34798       DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
34799       DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
34800       DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
34801       DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
34802       DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
34803       DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
34804 C-----N=20
34805       DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
34806       DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
34807       DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
34808       DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
34809       DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
34810       DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
34811       DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
34812       DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
34813       DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
34814       DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
34815 C-----N=24
34816       DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
34817       DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
34818       DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
34819       DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
34820       DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
34821       DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
34822       DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
34823       DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
34824       DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
34825       DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
34826       DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
34827       DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
34828 C-----N=32
34829       DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
34830       DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
34831       DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
34832       DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
34833       DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
34834       DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
34835       DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
34836       DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
34837       DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
34838       DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
34839       DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
34840       DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
34841       DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
34842       DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
34843       DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
34844       DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
34845 C-----N=40
34846       DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
34847       DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
34848       DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
34849       DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
34850       DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
34851       DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
34852       DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
34853       DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
34854       DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
34855       DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
34856       DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
34857       DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
34858       DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
34859       DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
34860       DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
34861       DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
34862       DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
34863       DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
34864       DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
34865       DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
34866 C-----N=48
34867       DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
34868       DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
34869       DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
34870       DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
34871       DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
34872       DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
34873       DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
34874       DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
34875       DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
34876       DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
34877       DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
34878       DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
34879       DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
34880       DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
34881       DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
34882       DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
34883       DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
34884       DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
34885       DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
34886       DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
34887       DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
34888       DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
34889       DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
34890       DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
34891 C-----N=64
34892       DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
34893       DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
34894       DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
34895       DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
34896       DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
34897       DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
34898       DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
34899       DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
34900       DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
34901       DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
34902       DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
34903       DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
34904       DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
34905       DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
34906       DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
34907       DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
34908       DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
34909       DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
34910       DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
34911       DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
34912       DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
34913       DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
34914       DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
34915       DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
34916       DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
34917       DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
34918       DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
34919       DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
34920       DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
34921       DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
34922       DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
34923       DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
34924 C-----N=80
34925       DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
34926       DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
34927       DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
34928       DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
34929       DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
34930       DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
34931       DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
34932       DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
34933       DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
34934       DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
34935       DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
34936       DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
34937       DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
34938       DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
34939       DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
34940       DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
34941       DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
34942       DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
34943       DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
34944       DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
34945       DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
34946       DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
34947       DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
34948       DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
34949       DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
34950       DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
34951       DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
34952       DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
34953       DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
34954       DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
34955       DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
34956       DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
34957       DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
34958       DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
34959       DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
34960       DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
34961       DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
34962       DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
34963       DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
34964       DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
34965 C-----N=96
34966       DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
34967       DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
34968       DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
34969       DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
34970       DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
34971       DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
34972       DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
34973       DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
34974       DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
34975       DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
34976       DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
34977       DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
34978       DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
34979       DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
34980       DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
34981       DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
34982       DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
34983       DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
34984       DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
34985       DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
34986       DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
34987       DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
34988       DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
34989       DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
34990       DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
34991       DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
34992       DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
34993       DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
34994       DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
34995       DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
34996       DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
34997       DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
34998       DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
34999       DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
35000       DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
35001       DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
35002       DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
35003       DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
35004       DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
35005       DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
35006       DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
35007       DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
35008       DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
35009       DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
35010       DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
35011       DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
35012       DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
35013       DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
35014       DATA IBD/0/
35015       IF(IBD.NE.0) RETURN
35016       IBD=1
35017       DO 10 I=1,273
35018         B(I) = A(I)
35019         Y(I) = X(I)
35020  10   CONTINUE
35021       DO 20 I=1,96
35022         LTAB(I) = KTAB(I)
35023  20   CONTINUE
35024       END
35025
35026 CDECK  ID>, PHO_DZEROX
35027       DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
35028 C**********************************************************************
35029 C
35030 C     Based on
35031 C
35032 C        J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
35033 C        Guaranteed Convergence for Finding a Zero of a Function,
35034 C        ACM Trans. Math. Software 1 (1975) 330-345.
35035 C
35036 C        (MODE = 1: Algorithm M;    MODE = 2: Algorithm R)
35037 C
35038 C        CERNLIB C200
35039 C
35040 C***********************************************************************
35041       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35042       SAVE
35043
35044 C  input/output channels
35045       INTEGER LI,LO
35046       COMMON /POINOU/ LI,LO
35047
35048       CHARACTER NAME*(*)
35049       PARAMETER (NAME = 'PHO_DZEROX')
35050       LOGICAL LMT
35051       DIMENSION IM1(2),IM2(2),LMT(2)
35052       EXTERNAL F
35053
35054       PARAMETER (Z1 = 1, HALF = Z1/2)
35055
35056       DATA IM1 /2,3/, IM2 /-1,3/
35057
35058       IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
35059        C=-2D+10
35060        WRITE(LO,100) NAME,MODE
35061        GO TO 99
35062       ENDIF
35063       FA=F(B0)
35064       FB=F(A0)
35065       IF(FA*FB .GT. 0) THEN
35066        C=-3D+10
35067        WRITE(LO,101) NAME
35068        GO TO 99
35069       ENDIF
35070       ATL=ABS(EPS)
35071       B=A0
35072       A=B0
35073       LMT(2)=.TRUE.
35074       MF=2
35075     1 C=A
35076       FC=FA
35077     2 IE=0
35078     3 IF(ABS(FC) .LT. ABS(FB)) THEN
35079        IF(C .NE. A) THEN
35080         D=A
35081         FD=FA
35082        END IF
35083        A=B
35084        B=C
35085        C=A
35086        FA=FB
35087        FB=FC
35088        FC=FA
35089       END IF
35090       TOL=ATL*(1+ABS(C))
35091       H=HALF*(C+B)
35092       HB=H-B
35093       IF(ABS(HB) .GT. TOL) THEN
35094        IF(IE .GT. IM1(MODE)) THEN
35095         W=HB
35096        ELSE
35097         TOL=TOL*SIGN(Z1,HB)
35098         P=(B-A)*FB
35099         LMT(1)=IE .LE. 1
35100         IF(LMT(MODE)) THEN
35101          Q=FA-FB
35102          LMT(2)=.FALSE.
35103         ELSE
35104          FDB=(FD-FB)/(D-B)
35105          FDA=(FD-FA)/(D-A)
35106          P=FDA*P
35107          Q=FDB*FA-FDA*FB
35108         END IF
35109         IF(P .LT. 0) THEN
35110          P=-P
35111          Q=-Q
35112         END IF
35113         IF(IE .EQ. IM2(MODE)) P=P+P
35114         IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
35115          W=TOL
35116         ELSEIF(P .LT. HB*Q) THEN
35117          W=P/Q
35118         ELSE
35119          W=HB
35120         END IF
35121        END IF
35122        D=A
35123        A=B
35124        FD=FA
35125        FA=FB
35126        B=B+W
35127        MF=MF+1
35128        IF(MF .GT. MAXF) THEN
35129         WRITE(LO,102) NAME
35130         GO TO 99
35131        ENDIF
35132        FB=F(B)
35133        IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35134        IF(W .EQ. HB) GO TO 2
35135        IE=IE+1
35136        GO TO 3
35137       END IF
35138    99 CONTINUE
35139       PHO_DZEROX=C
35140       RETURN
35141   100 FORMAT(1X,A,': mode = ',I3,' illegal')
35142   101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35143   102 FORMAT(1X,A,': too many function calls')
35144
35145       END
35146
35147 CDECK  ID>, PHO_EXPINT
35148       DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35149 C***********************************************************************
35150 C
35151 C     function to calculate  E_i(x) = -E_1(-x)
35152 C
35153 C     based on CERNLIB C337   (changed by R.Engel 10/1993)
35154 C
35155 C***********************************************************************
35156       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35157       SAVE
35158
35159 C  input/output channels
35160       INTEGER LI,LO
35161       COMMON /POINOU/ LI,LO
35162
35163       DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35164       DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35165       DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35166
35167       DATA  X0 /0.37250 74107 8137D0/
35168       DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35169       DATA P1
35170      1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35171      2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35172      3 -4.34981 43832 952D+2/
35173       DATA Q1
35174      1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35175      2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35176      3 +7.53585 64359 843D+2/
35177       DATA P2
35178      1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35179      2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35180      3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35181      4 +4.65627 10797 510D-7/
35182       DATA Q2
35183      1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35184      2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35185      3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35186      4 +1.00000 00000 000D+0/
35187       DATA P3
35188      1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35189      2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35190      3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35191       DATA Q3
35192      1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35193      2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35194      3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35195       DATA P4
35196      1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35197      2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35198      3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35199      4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35200       DATA Q4
35201      1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35202      2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35203      3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35204      4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35205       DATA A1
35206      1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35207      2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35208      3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35209      4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35210       DATA B1
35211      1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35212      2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35213      3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35214      4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35215       DATA A2
35216      1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35217      2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35218      3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35219      4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35220       DATA B2
35221      1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35222      2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35223      3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35224      4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35225       DATA A3
35226      1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35227      2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35228      3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35229       DATA B3
35230      1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35231      2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35232      3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35233 C
35234 C  conversion to E_i function
35235       X = -RXM
35236 C
35237       IF(X .LE. XL(1)) THEN
35238        AP=A3(1)-X
35239        DO 1 I = 2,5
35240     1  AP=A3(I)-X+B3(I)/AP
35241        Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35242       ELSEIF(X .LE. XL(2)) THEN
35243        AP=A2(1)-X
35244        DO 2 I = 2,7
35245     2     AP=A2(I)-X+B2(I)/AP
35246        Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35247       ELSEIF(X .LE. XL(3)) THEN
35248        AP=A1(1)-X
35249        DO 3 I = 2,7
35250     3     AP=A1(I)-X+B1(I)/AP
35251        Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35252       ELSEIF(X .LT. XL(4)) THEN
35253        V=-2.D0*(X/3.D0+1.D0)
35254        BP=0.D0
35255        DP=P4(1)
35256        DO 4 I = 2,8
35257           AP=BP
35258           BP=DP
35259     4     DP=P4(I)-AP+V*BP
35260        BQ=0.D0
35261        DQ=Q4(1)
35262        DO 14 I = 2,8
35263           AQ=BQ
35264           BQ=DQ
35265    14     DQ=Q4(I)-AQ+V*BQ
35266        Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35267       ELSEIF(X .EQ. XL(4)) THEN
35268 *      CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35269 *      IF(MFLAG) THEN
35270 *       IF(LGFILE .EQ. 0) THEN
35271 *        WRITE(LO,100) ENAME
35272 *       ELSE
35273 *        WRITE(LGFILE,100) ENAME
35274 *       ENDIF
35275 *      ENDIF
35276 *      IF(.NOT.RFLAG) CALL ABEND
35277        PHO_EXPINT=0.D0
35278        RETURN
35279       ELSEIF(X .LT. XL(5)) THEN
35280        AP=P1(1)
35281        AQ=Q1(1)
35282        DO 5 I = 2,5
35283           AP=P1(I)+X*AP
35284     5     AQ=Q1(I)+X*AQ
35285        Y=-LOG(X)+AP/AQ
35286       ELSEIF(X .LE. XL(6)) THEN
35287        Y=1.D0/X
35288        AP=P2(1)
35289        AQ=Q2(1)
35290        DO 6 I = 2,7
35291           AP=P2(I)+Y*AP
35292     6     AQ=Q2(I)+Y*AQ
35293        Y=EXP(-X)*AP/AQ
35294       ELSE
35295        Y=1.D0/X
35296        AP=P3(1)
35297        AQ=Q3(1)
35298        DO 7 I = 2,6
35299           AP=P3(I)+Y*AP
35300     7     AQ=Q3(I)+Y*AQ
35301        Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35302       ENDIF
35303 C  sign conversion to E_i
35304       PHO_EXPINT=-Y
35305
35306       END
35307
35308 CDECK  ID>, PHO_RNDBET
35309       DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35310 C********************************************************************
35311 C
35312 C     RANDOM NUMBER GENERATION FROM BETA
35313 C     DISTRIBUTION IN REGION  0 < X < 1.
35314 C     F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35315 C                                                        *GAMM(ETA))
35316 C
35317 C********************************************************************
35318       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35319       SAVE
35320
35321       Y = PHO_RNDGAM(1.D0,GAM)
35322       Z = PHO_RNDGAM(1.D0,ETA)
35323
35324       PHO_RNDBET = Y/(Y+Z)
35325
35326       END
35327
35328 CDECK  ID>, PHO_RNDGAM
35329       DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35330 C********************************************************************
35331 C
35332 C     RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35333 C     F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35334 C
35335 C********************************************************************
35336       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35337       SAVE
35338 C
35339       NCOU=0
35340       N = ETA
35341       F = ETA - N
35342       IF(F.EQ.0.D0) GOTO 20
35343    10 R = DT_RNDM(ETA)
35344       NCOU=NCOU+1
35345       IF (NCOU.GE.11) GOTO 20
35346       IF(R.LT.F/(F+2.71828D0)) GOTO 30
35347       YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35348       IF(ABS(YYY).GT.50.D0) GOTO 20
35349       Y = EXP(YYY)
35350       IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35351       GOTO 40
35352    20 Y = 0.D0
35353       GOTO 50
35354    30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35355       IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35356    40 IF(N.EQ.0) GOTO 70
35357    50 Z = 1.D0
35358       DO 60 I = 1,N
35359    60 Z = Z*DT_RNDM(Y)
35360       Y = Y-LOG(Z+1.0D-9)
35361    70 PHO_RNDGAM = Y/ALAM
35362       RETURN
35363       END
35364
35365 CDECK  ID>, PHO_SFECFE
35366       SUBROUTINE PHO_SFECFE(SFE,CFE)
35367 C**********************************************************************
35368 C
35369 C     fast random SIN(X) COS(X) selection
35370 C
35371 C**********************************************************************
35372       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35373       SAVE
35374 C
35375     1 CONTINUE
35376         X=DT_RNDM(XX)
35377         Y=DT_RNDM(YY)
35378         XX=X*X
35379         YY=Y*Y
35380         XY=XX+YY
35381       IF(XY.GT.1.D0) GOTO 1
35382       CFE=(XX-YY)/XY
35383       SFE=2.D0*X*Y/XY
35384       IF(DT_RNDM(XY).LT.0.5D0) THEN
35385         SFE=-SFE
35386       ENDIF
35387       END
35388
35389 CDECK  ID>, PHO_SWAPD
35390       SUBROUTINE PHO_SWAPD(D1,D2)
35391 C********************************************************************
35392 C
35393 C     exchange of argument values (double precision)
35394 C
35395 C********************************************************************
35396       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35397       D = D1
35398       D1 = D2
35399       D2 = D
35400       END
35401
35402 CDECK  ID>, PHO_SWAPI
35403       SUBROUTINE PHO_SWAPI(I1,I2)
35404 C********************************************************************
35405 C
35406 C     exchange of argument values (integer)
35407 C
35408 C********************************************************************
35409       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35410       K = I1
35411       I1 = I2
35412       I2 = K
35413       END
35414
35415 CDECK  ID>, PHO_HADCSL
35416       SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35417      &                     SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35418 C***********************************************************************
35419 C
35420 C     low-energy cross section parametrizations
35421 C
35422 C     input:   ID1,ID2     PDG IDs of particles (meson first)
35423 C              ECM         c.m. energy (GeV)
35424 C              PLAB        lab. momentum (second particle at rest)
35425 C              IMODE       1    ECM given, PLAB ignored
35426 C                          2    PLAB given, ECM ignored
35427 C
35428 C     output:  SIGTOT      total cross section (mb)
35429 C              SIGEL       elastic cross section (mb)
35430 C              SIGDIF      diffracive cross section (sd-1,sd-2,dd), (mb)
35431 C              SLOPE       forward elastic slope (GeV**-2)
35432 C              RHO         real/imaginary part of elastic amplitude
35433 C
35434 C     comments:
35435 C
35436 C     - low-energy data interpolation uses PDG fits from 1992 issue
35437 C     - high-energy extrapolation by Donnachie-Landshoff like fit made
35438 C       by PDG 1996
35439 C     - analytic extension of amplitude to calculate rho
35440 C
35441 C***********************************************************************
35442
35443       IMPLICIT NONE
35444
35445       SAVE
35446
35447       INTEGER ID1,ID2,IMODE
35448       DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35449
35450 C  input/output channels
35451       INTEGER LI,LO
35452       COMMON /POINOU/ LI,LO
35453 C  some constants
35454       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35455       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35456      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35457 C  model switches and parameters
35458       CHARACTER*8 MDLNA
35459       INTEGER ISWMDL,IPAMDL
35460       DOUBLE PRECISION PARMDL
35461       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35462
35463       INTEGER K
35464       DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35465      &  SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35466
35467       DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35468
35469       DATA TPDG92  /
35470      &  3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35471      &  3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35472      &  5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35473      &  5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35474      &  4.D0, 340.D0,  16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35475      &  4.D0, 340.D0,  0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35476      &  2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35477      &  2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35478      &  2.D0, 310.D0,  18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35479      &  2.D0, 310.D0,  5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35480      &  3.D0, 310.D0,  32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35481      &  3.D0, 310.D0,  7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0  /
35482
35483       DATA TPDG96  /
35484      &  50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35485      &         77.15D0,-21.05D0,0.46D0,0.9D0,
35486      &  50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35487      &         77.15D0,21.05D0,0.46D0,0.9D0,
35488      &  10.D0, 13.70,0.079D0,0.25D0,0.D0,
35489      &         31.85D0,-4.05D0,0.45D0,0.9D0,
35490      &  10.D0, 13.70,0.079D0,0.25D0,0.D0,
35491      &         31.85D0,4.05D0,0.45D0,0.9D0,
35492      &  10.D0, 12.20,0.079D0,0.25D0,0.D0,
35493      &         17.35D0,-9.05D0,0.50D0,0.9D0,
35494      &  10.D0, 12.20,0.079D0,0.25D0,0.D0,
35495      &         17.35D0,9.05D0,0.50D0,0.9D0  /
35496
35497       DATA BURQ83 /
35498      &  11.13D0, -6.21D0, 0.30D0,
35499      &  11.13D0,  7.23D0, 0.30D0,
35500      &  9.11D0,  -0.73D0, 0.28D0,
35501      &  9.11D0,   0.65D0, 0.28D0,
35502      &  8.55D0,  -5.98D0, 0.28D0,
35503      &  8.55D0,   1.60D0, 0.28D0  /
35504
35505       DATA XMA /
35506      &  2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35507
35508 C  find index
35509       IF(ID2.NE.2212) THEN
35510         GOTO 100
35511       ELSE IF(ID1.EQ.2212) THEN
35512         K = 1
35513       ELSE IF(ID1.EQ.-2212) THEN
35514         K = 2
35515       ELSE IF(ID1.EQ.211) THEN
35516         K = 3
35517       ELSE IF(ID1.EQ.-211) THEN
35518         K = 4
35519       ELSE IF(ID1.EQ.321) THEN
35520         K = 5
35521       ELSE IF(ID1.EQ.-321) THEN
35522         K = 6
35523       ELSE
35524         GOTO 100
35525       ENDIF
35526
35527 C  calculate lab momentum
35528       IF(IMODE.EQ.1) THEN
35529         SS = ECM**2
35530         E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35531         PL = SQRT(E1*E1-XMA(K)**2)
35532       ELSE IF(IMODE.EQ.2) THEN
35533         PL = PLAB
35534         SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35535         ECM = SQRT(SS)
35536       ELSE
35537         WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35538         RETURN
35539       ENDIF
35540       PLL = LOG(PL)
35541
35542 C  check against lower limit
35543       IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35544
35545       XP  = TPDG96(2,K)*SS**TPDG96(3,K)
35546       YP  = TPDG96(6,K)/SS**TPDG96(8,K)
35547       YM  = TPDG96(7,K)/SS**TPDG96(8,K)
35548
35549       PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35550       PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35551       RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35552       SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35553
35554 C  select energy range and interpolation method
35555       IF(PL.LT.TPDG96(1,K)) THEN
35556         SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35557      &          + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35558         SIGEL  = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35559      &          + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35560       ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35561         SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35562      &          + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35563         SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35564      &          + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35565         SIGTO2 = YP+YM+XP
35566         SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35567         X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35568         X1 = 1.D0 - X2
35569         SIGTOT = SIGTO2*X2 + SIGTO1*X1
35570         SIGEL  = SIGEL2*X2 + SIGEL1*X1
35571       ELSE
35572         SIGTOT = YP+YM+XP
35573         SIGEL  = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35574       ENDIF
35575
35576 C  no parametrization of diffraction implemented
35577       SIGDIF(1) = -1.D0
35578       SIGDIF(2) = -1.D0
35579       SIGDIF(3) = -1.D0
35580
35581       RETURN
35582
35583  100  CONTINUE
35584         WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35585      &    'invalid particle combination: ',ID1,ID2
35586         RETURN
35587
35588  200  CONTINUE
35589         WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35590      &    'energy too small (Ecm,Plab): ',ECM,PLAB
35591
35592       END
35593
35594 CDECK  ID>, PHO_CSDIFF
35595       SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35596      &  sig_sd1,sig_sd2,sig_dd)
35597 C***********************************************************************
35598 C
35599 C     cross section for diffraction dissociation according to
35600 C     Goulianos' parametrization (Ref: PL B358 (1995) 379)
35601 C
35602 C     in addition rescaling for different particles is applied using
35603 C     internal rescaling tables (not implemented yet)
35604 C
35605 C     input:     Id1/2       PDG ID's of incoming particles
35606 C                SS          squared c.m. energy (GeV**2)
35607 C                Xi_min      min. diff mass (squared) = Xi_min*SS
35608 C                Xi_max      max. diff mass (squared) = Xi_max*SS
35609 C
35610 C     output:    sig_sd1     cross section for diss. of particle 1 (mb)
35611 C                sig_sd2     cross section for diss. of particle 2 (mb)
35612 C                sig_dd      cross section for diss. of both particles
35613 C
35614 C***********************************************************************
35615
35616       IMPLICIT NONE
35617
35618       SAVE
35619
35620       INTEGER Id1,Id2
35621       DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35622
35623 C  input/output channels
35624       INTEGER LI,LO
35625       COMMON /POINOU/ LI,LO
35626 C  some constants
35627       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35628       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35629      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35630
35631       DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35632       DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35633      &  fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35634      &  xms_1,xms_2,CSdiff
35635
35636       INTEGER Ngau1,Ngau2,i1,i2
35637
35638 C  model parameters
35639
35640       DATA delta    / 0.104d0 /
35641       DATA alphap   / 0.25d0 /
35642       DATA beta0    / 6.56d0 /
35643       DATA gpom0    / 1.21d0 /
35644       DATA xm_p     / 0.938d0 /
35645       DATA x_rad2   / 0.71d0 /
35646
35647 C  integration precision
35648
35649       DATA Ngau1    / 96 /
35650       DATA Ngau2    / 96 /
35651
35652       sig_sd1 = 0.d0
35653       sig_sd2 = 0.d0
35654       sig_dd  = 0.d0
35655
35656       IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35657
35658         xm4_p2 = 4.D0*xm_p**2
35659         fac = beta0**2/(16.D0*PI)
35660
35661         t1 = -5.D0
35662         t2 = 0.D0
35663         tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35664         tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35665
35666 C  flux renormalization and cross section
35667
35668         Xnorm  = 0.d0
35669
35670         xil = log(1.5d0/SS)
35671         xiu = log(0.1d0)
35672
35673         IF(xiu.LE.xil) goto 1000
35674
35675         CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
35676         CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
35677
35678         do i1=1,Ngau1
35679
35680           xi = exp(xpos1(i1))
35681           w_xi = Xwgh1(i1)
35682
35683           do i2=1,Ngau2
35684
35685             tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35686
35687             alpha_t =  1.D0+delta+alphap*tt
35688             f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35689
35690             Xnorm = Xnorm
35691      &        + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35692
35693           enddo
35694         enddo
35695
35696         Xnorm = Xnorm*fac
35697
35698  1000   continue
35699
35700         XIL = LOG(Xi_min)
35701         XIU = LOG(Xi_max)
35702
35703         T1 = -5.D0
35704         T2 = 0.D0
35705
35706         TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35707         TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35708
35709 C  single diffraction diss. cross section
35710
35711         CSdiff = 0.d0
35712
35713         IF(XIU.LE.XIL) goto 2000
35714
35715         CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
35716         CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
35717
35718         do i1=1,Ngau1
35719
35720           xi = exp(xpos1(i1))
35721           w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
35722
35723           do i2=1,Ngau2
35724
35725             tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35726
35727             alpha_t =  1.D0+delta+alphap*tt
35728             f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35729
35730             CSdiff = CSdiff
35731      &        + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35732
35733           enddo
35734         enddo
35735
35736         CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
35737
35738 *       WRITE(LO,'(1x,1p,4e14.3)')
35739 *    &    sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
35740
35741         sig_sd1 = CSdiff
35742         sig_sd2 = CSdiff
35743
35744  2000   continue
35745
35746 C  double diffraction dissociation cross section
35747
35748         CSdiff = 0.d0
35749
35750         xil = log(1.5d0/SS)
35751         xiu = log(Xi_max/1.5d0)
35752
35753         IF(xiu.LE.xil) goto 3000
35754
35755         fac = (beta0*gpom0*SS**delta
35756      &         /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
35757      &       /(2.d0*alphap)
35758
35759         CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
35760
35761         do i1=1,Ngau1
35762
35763           xi = exp(xpos1(i1))
35764           xms_1 = xi*SS
35765
35766           xiu = log(Xi_max/(xi*SS))
35767
35768           if(xil.lt.xiu) then
35769
35770             CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
35771
35772             do i2=1,Ngau2
35773
35774               xms_2 = exp(xpos2(i2))*SS
35775               CSdiff = CSdiff
35776      &          + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
35777      &            *xwgh1(i1)*xwgh2(i2)
35778
35779             enddo
35780
35781           endif
35782
35783         enddo
35784
35785         sig_dd = CSdiff*fac*GEV2MB
35786
35787  3000   continue
35788
35789       ELSE
35790
35791         WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
35792      &    'invalid particle combination (Id1/2)',Id1,Id2
35793
35794       ENDIF
35795
35796       END
35797
35798 CDECK  ID>, PHO_ALLM97
35799       DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
35800 C**********************************************************************
35801 C
35802 C     ALLM97 parametrization for gamma*-p cross section
35803 C     (for F2 see comments, code adapted from V. Shekelyan, H1)
35804 C
35805 C**********************************************************************
35806
35807       IMPLICIT NONE
35808
35809       SAVE
35810
35811 C  input/output channels
35812       INTEGER LI,LO
35813       COMMON /POINOU/ LI,LO
35814
35815       DOUBLE PRECISION Q2,W
35816       DOUBLE PRECISION M02,M12,LAM2,M22
35817       DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
35818       DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
35819       DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
35820      &                 AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
35821       DATA ALFA,XMP2 /112.2D0 , .8802D0 /
35822
35823       W2=W*W
35824       PHO_ALLM97 = 0.D0
35825
35826 C  pomeron
35827       S11   =   0.28067D0
35828       S12   =   0.22291D0
35829       S13   =   2.1979D0
35830       A11   =  -0.0808D0
35831       A12   =  -0.44812D0
35832       A13   =   1.1709D0
35833       B11   =   0.60243D0
35834       B12   =   1.3754D0
35835       B13   =   1.8439D0
35836       M12   =  49.457D0
35837
35838 C  reggeon
35839       S21   =   0.80107D0
35840       S22   =   0.97307D0
35841       S23   =   3.4942D0
35842       A21   =   0.58400D0
35843       A22   =   0.37888D0
35844       A23   =   2.6063D0
35845       B21   =   0.10711D0
35846       B22   =   1.9386D0
35847       B23   =   0.49338D0
35848       M22   =   0.15052D0
35849 C
35850       M02   =   0.31985D0
35851       LAM2  =   0.065270D0
35852       Q02   =   0.46017D0 +LAM2
35853
35854 C
35855       S=0.
35856       T=LOG((Q2+Q02)/LAM2)
35857       T0=LOG(Q02/LAM2)
35858       IF(Q2.GT.0.D0) S=LOG(T/T0)
35859       Z=1.D0
35860
35861       IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
35862
35863       IF(S.LT.0.01D0) THEN
35864
35865 C   pomeron part
35866
35867         XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35868
35869         AP=A11
35870         BP=B11**2
35871
35872         SP=S11
35873         F2P=SP*XP**AP*Z**BP
35874
35875 C   reggeon part
35876
35877         XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35878
35879         AR=A21
35880         BR=B21**2
35881
35882         SR=S21
35883         F2R=SR*XR**AR*Z**BR
35884
35885       ELSE
35886
35887 C   pomeron part
35888
35889         XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35890
35891         AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
35892
35893         BP=B11**2+B12**2*S**B13
35894
35895         SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
35896
35897         F2P=SP*XP**AP*Z**BP
35898
35899 C   reggeon part
35900
35901         XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35902
35903         AR=A21+A22*S**A23
35904         BR=B21**2+B22**2*S**B23
35905
35906         SR=S21+S22*S**S23
35907         F2R=SR*XR**AR*Z**BR
35908
35909       ENDIF
35910
35911 *     F2 = (F2P+F2R)*Q2/(Q2+M02)
35912
35913       CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
35914       PHO_ALLM97 = CIN*(F2P+F2R)
35915
35916       END
35917
35918 CDECK  ID>, PHO_DOR98LO
35919       SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
35920 C***********************************************************************
35921 C
35922 C   GRV98 parton densities, leading order set
35923 C
35924 C                  For a detailed explanation see
35925 C                   M. Glueck, E. Reya, A. Vogt :
35926 C        hep-ph/9806404  =  DO-TH 98/07  =  WUE-ITP-98-019
35927 C                  (To appear in Eur. Phys. J. C)
35928 C
35929 C   interpolation routine based on the original GRV98PA routine,
35930 C   adapted to define interpolation table as DATA statements
35931 C
35932 C                                                   (R.Engel, 09/98)
35933 C
35934 C
35935 C   INPUT:   X  =  Bjorken-x        (between  1.E-9 and 1.)
35936 C            Q2 =  scale in GeV**2  (between  0.8 and 1.E6)
35937 C
35938 C   OUTPUT:  UV = u - u(bar),  DV = d - d(bar),  US = u(bar),
35939 C            DS = d(bar),  SS = s = s(bar),  GL = gluon.
35940 C            Always x times the distribution is returned.
35941 C
35942 C******************************************************i****************
35943       IMPLICIT DOUBLE PRECISION (A-H, O-Z)
35944       SAVE
35945
35946 C  input/output channels
35947       INTEGER LI,LO
35948       COMMON /POINOU/ LI,LO
35949
35950       PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
35951       DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
35952      1          XSF(NX,NQ), XGF(NX,NQ),
35953      2          XT(NARG), NA(NARG), ARRF(NX+NQ)
35954
35955       DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
35956      &  XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
35957
35958       EQUIVALENCE (XUVF(1,1),XUVF_L(1))
35959       EQUIVALENCE (XDVF(1,1),XDVF_L(1))
35960       EQUIVALENCE (XDEF(1,1),XDEF_L(1))
35961       EQUIVALENCE (XUDF(1,1),XUDF_L(1))
35962       EQUIVALENCE (XSF(1,1),XSF_L(1))
35963       EQUIVALENCE (XGF(1,1),XGF_L(1))
35964
35965       DATA (ARRF(K),K=    1,   95) /
35966      &  -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
35967      &  -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
35968      &  -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
35969      &  -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
35970      &  -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
35971      &  -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
35972      &  -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
35973      &  -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
35974      &  -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
35975      &  -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
35976      &  -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
35977      &  -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
35978      &  -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
35979      &  -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
35980      &   2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
35981      &   2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
35982      &   4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
35983      &   7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
35984      &   1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
35985       DATA (XUVF_L(K),K=    1,  114) /
35986      &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
35987      &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
35988      &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
35989      &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
35990      &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
35991      &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
35992      &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
35993      &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
35994      &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
35995      &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
35996      &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
35997      &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
35998      &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
35999      &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
36000      &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
36001      &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
36002      &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
36003      &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
36004      &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
36005       DATA (XUVF_L(K),K=  115,  228) /
36006      &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
36007      &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
36008      &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
36009      &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
36010      &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
36011      &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
36012      &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
36013      &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
36014      &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
36015      &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
36016      &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
36017      &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
36018      &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
36019      &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
36020      &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
36021      &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
36022      &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
36023      &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
36024      &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
36025       DATA (XUVF_L(K),K=  229,  342) /
36026      &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
36027      &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
36028      &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
36029      &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
36030      &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
36031      &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
36032      &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
36033      &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
36034      &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
36035      &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
36036      &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
36037      &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
36038      &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
36039      &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
36040      &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
36041      &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
36042      &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
36043      &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
36044      &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
36045       DATA (XUVF_L(K),K=  343,  456) /
36046      &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
36047      &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
36048      &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
36049      &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
36050      &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
36051      &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
36052      &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
36053      &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
36054      &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
36055      &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
36056      &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
36057      &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
36058      &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
36059      &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
36060      &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
36061      &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
36062      &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
36063      &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
36064      &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
36065       DATA (XUVF_L(K),K=  457,  570) /
36066      &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
36067      &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
36068      &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
36069      &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
36070      &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
36071      &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
36072      &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
36073      &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
36074      &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
36075      &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
36076      &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
36077      &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
36078      &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
36079      &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
36080      &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
36081      &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
36082      &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
36083      &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
36084      &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
36085       DATA (XUVF_L(K),K=  571,  684) /
36086      &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
36087      &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
36088      &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
36089      &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
36090      &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
36091      &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
36092      &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
36093      &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
36094      &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
36095      &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
36096      &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
36097      &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
36098      &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
36099      &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
36100      &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
36101      &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
36102      &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
36103      &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
36104      &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
36105       DATA (XUVF_L(K),K=  685,  798) /
36106      &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
36107      &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36108      &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36109      &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36110      &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36111      &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36112      &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36113      &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36114      &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36115      &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36116      &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36117      &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36118      &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36119      &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36120      &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36121      &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36122      &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36123      &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36124      &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36125       DATA (XUVF_L(K),K=  799,  912) /
36126      &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36127      &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36128      &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36129      &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36130      &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36131      &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36132      &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36133      &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36134      &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36135      &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36136      &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36137      &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36138      &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36139      &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36140      &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36141      &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36142      &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36143      &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36144      &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36145       DATA (XUVF_L(K),K=  913, 1026) /
36146      &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36147      &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36148      &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36149      &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36150      &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36151      &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36152      &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36153      &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36154      &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36155      &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36156      &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36157      &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36158      &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36159      &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36160      &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36161      &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36162      &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36163      &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36164      &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36165       DATA (XUVF_L(K),K= 1027, 1140) /
36166      &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36167      &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36168      &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36169      &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36170      &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36171      &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36172      &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36173      &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36174      &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36175      &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36176      &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36177      &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36178      &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36179      &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36180      &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36181      &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36182      &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36183      &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36184      &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36185       DATA (XUVF_L(K),K= 1141, 1254) /
36186      &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36187      &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36188      &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36189      &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36190      &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36191      &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36192      &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36193      &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36194      &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36195      &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36196      &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36197      &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36198      &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36199      &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36200      &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36201      &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36202      &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36203      &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36204      &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36205       DATA (XUVF_L(K),K= 1255, 1368) /
36206      &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36207      &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36208      &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36209      &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36210      &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36211      &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36212      &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36213      &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36214      &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36215      &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36216      &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36217      &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36218      &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36219      &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36220      &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36221      &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36222      &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36223      &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36224      &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36225       DATA (XUVF_L(K),K= 1369, 1482) /
36226      &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36227      &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36228      &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36229      &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36230      &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36231      &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36232      &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36233      &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36234      &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36235      &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36236      &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36237      &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36238      &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36239      &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36240      &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36241      &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36242      &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36243      &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36244      &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36245       DATA (XUVF_L(K),K= 1483, 1596) /
36246      &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36247      &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36248      &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36249      &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36250      &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36251      &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36252      &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36253      &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36254      &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36255      &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36256      &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36257      &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36258      &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36259      &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36260      &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36261      &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36262      &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36263      &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36264      &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36265       DATA (XUVF_L(K),K= 1597, 1710) /
36266      &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36267      &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36268      &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36269      &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36270      &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36271      &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36272      &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36273      &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36274      &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36275      &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36276      &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36277      &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36278      &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36279      &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36280      &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36281      &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36282      &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36283      &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36284      &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36285       DATA (XUVF_L(K),K= 1711, 1824) /
36286      &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36287      &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36288      &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36289      &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36290      &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36291      &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36292      &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36293      &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36294      &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36295      &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36296      &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36297      &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36298      &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36299      &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36300      &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36301      &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36302      &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36303      &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36304      &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36305       DATA (XUVF_L(K),K= 1825, 1836) /
36306      &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36307      &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36308       DATA (XDVF_L(K),K=    1,  114) /
36309      &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36310      &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36311      &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36312      &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36313      &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36314      &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36315      &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36316      &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36317      &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36318      &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36319      &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36320      &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36321      &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36322      &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36323      &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36324      &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36325      &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36326      &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36327      &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36328       DATA (XDVF_L(K),K=  115,  228) /
36329      &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36330      &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36331      &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36332      &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36333      &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36334      &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36335      &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36336      &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36337      &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36338      &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36339      &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36340      &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36341      &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36342      &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36343      &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36344      &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36345      &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36346      &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36347      &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36348       DATA (XDVF_L(K),K=  229,  342) /
36349      &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36350      &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36351      &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36352      &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36353      &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36354      &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36355      &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36356      &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36357      &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36358      &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36359      &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36360      &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36361      &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36362      &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36363      &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36364      &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36365      &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36366      &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36367      &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36368       DATA (XDVF_L(K),K=  343,  456) /
36369      &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36370      &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36371      &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36372      &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36373      &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36374      &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36375      &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36376      &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36377      &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36378      &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36379      &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36380      &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36381      &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36382      &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36383      &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36384      &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36385      &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36386      &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36387      &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36388       DATA (XDVF_L(K),K=  457,  570) /
36389      &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36390      &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36391      &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36392      &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36393      &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36394      &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36395      &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36396      &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36397      &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36398      &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36399      &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36400      &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36401      &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36402      &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36403      &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36404      &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36405      &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36406      &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36407      &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36408       DATA (XDVF_L(K),K=  571,  684) /
36409      &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36410      &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36411      &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36412      &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36413      &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36414      &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36415      &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36416      &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36417      &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36418      &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36419      &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36420      &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36421      &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36422      &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36423      &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36424      &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36425      &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36426      &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36427      &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36428       DATA (XDVF_L(K),K=  685,  798) /
36429      &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36430      &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36431      &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36432      &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36433      &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36434      &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36435      &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36436      &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36437      &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36438      &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36439      &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36440      &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36441      &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36442      &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36443      &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36444      &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36445      &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36446      &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36447      &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36448       DATA (XDVF_L(K),K=  799,  912) /
36449      &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36450      &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36451      &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36452      &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36453      &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36454      &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36455      &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36456      &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36457      &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36458      &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36459      &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36460      &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36461      &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36462      &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36463      &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36464      &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36465      &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36466      &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36467      &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36468       DATA (XDVF_L(K),K=  913, 1026) /
36469      &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36470      &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36471      &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36472      &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36473      &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36474      &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36475      &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36476      &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36477      &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36478      &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36479      &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36480      &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36481      &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36482      &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36483      &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36484      &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36485      &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36486      &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36487      &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36488       DATA (XDVF_L(K),K= 1027, 1140) /
36489      &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36490      &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36491      &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36492      &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36493      &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36494      &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36495      &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36496      &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36497      &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36498      &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36499      &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36500      &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36501      &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36502      &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36503      &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36504      &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36505      &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36506      &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36507      &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36508       DATA (XDVF_L(K),K= 1141, 1254) /
36509      &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36510      &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36511      &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36512      &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36513      &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36514      &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36515      &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36516      &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36517      &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36518      &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36519      &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36520      &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36521      &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36522      &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36523      &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36524      &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36525      &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36526      &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36527      &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36528       DATA (XDVF_L(K),K= 1255, 1368) /
36529      &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36530      &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36531      &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36532      &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36533      &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36534      &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36535      &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36536      &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36537      &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36538      &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36539      &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36540      &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36541      &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36542      &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36543      &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36544      &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36545      &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36546      &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36547      &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36548       DATA (XDVF_L(K),K= 1369, 1482) /
36549      &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36550      &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36551      &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36552      &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36553      &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36554      &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36555      &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36556      &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36557      &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36558      &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36559      &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36560      &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36561      &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36562      &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36563      &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36564      &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36565      &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36566      &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36567      &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36568       DATA (XDVF_L(K),K= 1483, 1596) /
36569      &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36570      &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36571      &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36572      &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36573      &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36574      &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36575      &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36576      &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36577      &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36578      &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36579      &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36580      &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36581      &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36582      &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36583      &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36584      &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36585      &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36586      &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36587      &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36588       DATA (XDVF_L(K),K= 1597, 1710) /
36589      &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36590      &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36591      &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36592      &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36593      &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36594      &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36595      &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36596      &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36597      &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36598      &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36599      &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36600      &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36601      &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36602      &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36603      &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36604      &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36605      &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36606      &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36607      &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36608       DATA (XDVF_L(K),K= 1711, 1824) /
36609      &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36610      &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36611      &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36612      &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36613      &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36614      &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36615      &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36616      &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36617      &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36618      &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36619      &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36620      &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36621      &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36622      &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36623      &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36624      &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36625      &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36626      &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36627      &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36628       DATA (XDVF_L(K),K= 1825, 1836) /
36629      &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36630      &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36631       DATA (XDEF_L(K),K=    1,  114) /
36632      &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36633      &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36634      &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36635      &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36636      &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36637      &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36638      &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36639      &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36640      &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36641      &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36642      &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36643      &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36644      &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36645      &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36646      &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36647      &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36648      &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36649      &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36650      &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36651       DATA (XDEF_L(K),K=  115,  228) /
36652      &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36653      &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36654      &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36655      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36656      &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36657      &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36658      &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36659      &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36660      &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36661      &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36662      &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36663      &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36664      &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
36665      &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
36666      &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36667      &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
36668      &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
36669      &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
36670      &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
36671       DATA (XDEF_L(K),K=  229,  342) /
36672      &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
36673      &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
36674      &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
36675      &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
36676      &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
36677      &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
36678      &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
36679      &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
36680      &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
36681      &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
36682      &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
36683      &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
36684      &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
36685      &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
36686      &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
36687      &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
36688      &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
36689      &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
36690      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
36691       DATA (XDEF_L(K),K=  343,  456) /
36692      &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
36693      &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
36694      &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
36695      &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
36696      &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
36697      &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
36698      &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
36699      &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
36700      &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
36701      &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
36702      &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36703      &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
36704      &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
36705      &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
36706      &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
36707      &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
36708      &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
36709      &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
36710      &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
36711       DATA (XDEF_L(K),K=  457,  570) /
36712      &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
36713      &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
36714      &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36715      &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
36716      &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
36717      &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
36718      &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
36719      &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
36720      &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
36721      &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
36722      &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
36723      &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
36724      &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
36725      &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
36726      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
36727      &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
36728      &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
36729      &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
36730      &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
36731       DATA (XDEF_L(K),K=  571,  684) /
36732      &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
36733      &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
36734      &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
36735      &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
36736      &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
36737      &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
36738      &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36739      &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
36740      &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
36741      &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
36742      &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
36743      &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
36744      &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
36745      &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
36746      &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
36747      &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
36748      &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
36749      &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36750      &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
36751       DATA (XDEF_L(K),K=  685,  798) /
36752      &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
36753      &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
36754      &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
36755      &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
36756      &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
36757      &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
36758      &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
36759      &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
36760      &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
36761      &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
36762      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
36763      &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
36764      &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
36765      &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
36766      &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
36767      &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
36768      &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
36769      &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
36770      &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
36771       DATA (XDEF_L(K),K=  799,  912) /
36772      &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
36773      &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
36774      &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36775      &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
36776      &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
36777      &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
36778      &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
36779      &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
36780      &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
36781      &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
36782      &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
36783      &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
36784      &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
36785      &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36786      &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
36787      &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
36788      &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
36789      &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
36790      &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
36791       DATA (XDEF_L(K),K=  913, 1026) /
36792      &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
36793      &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
36794      &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
36795      &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
36796      &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
36797      &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
36798      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
36799      &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
36800      &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
36801      &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
36802      &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
36803      &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
36804      &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
36805      &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
36806      &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
36807      &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
36808      &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
36809      &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36810      &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
36811       DATA (XDEF_L(K),K= 1027, 1140) /
36812      &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
36813      &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
36814      &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
36815      &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
36816      &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
36817      &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
36818      &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
36819      &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
36820      &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
36821      &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36822      &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
36823      &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
36824      &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
36825      &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
36826      &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
36827      &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
36828      &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
36829      &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
36830      &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
36831       DATA (XDEF_L(K),K= 1141, 1254) /
36832      &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
36833      &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
36834      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
36835      &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
36836      &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
36837      &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
36838      &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
36839      &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
36840      &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
36841      &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
36842      &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
36843      &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
36844      &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
36845      &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36846      &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
36847      &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
36848      &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
36849      &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
36850      &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
36851       DATA (XDEF_L(K),K= 1255, 1368) /
36852      &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
36853      &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
36854      &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
36855      &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
36856      &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
36857      &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36858      &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
36859      &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
36860      &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
36861      &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
36862      &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
36863      &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
36864      &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
36865      &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
36866      &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
36867      &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
36868      &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
36869      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
36870      &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
36871       DATA (XDEF_L(K),K= 1369, 1482) /
36872      &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
36873      &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
36874      &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
36875      &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
36876      &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
36877      &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
36878      &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
36879      &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
36880      &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
36881      &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36882      &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
36883      &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
36884      &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
36885      &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
36886      &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
36887      &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
36888      &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
36889      &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
36890      &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
36891       DATA (XDEF_L(K),K= 1483, 1596) /
36892      &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
36893      &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36894      &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
36895      &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
36896      &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
36897      &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
36898      &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
36899      &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
36900      &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
36901      &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
36902      &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
36903      &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
36904      &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
36905      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
36906      &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
36907      &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
36908      &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
36909      &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
36910      &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
36911       DATA (XDEF_L(K),K= 1597, 1710) /
36912      &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
36913      &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
36914      &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
36915      &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
36916      &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
36917      &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36918      &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
36919      &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
36920      &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
36921      &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
36922      &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
36923      &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
36924      &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
36925      &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
36926      &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
36927      &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
36928      &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36929      &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
36930      &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
36931       DATA (XDEF_L(K),K= 1711, 1824) /
36932      &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
36933      &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
36934      &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
36935      &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
36936      &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
36937      &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
36938      &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
36939      &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
36940      &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
36941      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
36942      &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
36943      &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
36944      &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
36945      &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
36946      &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
36947      &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
36948      &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
36949      &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
36950      &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
36951       DATA (XDEF_L(K),K= 1825, 1836) /
36952      &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
36953      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
36954       DATA (XUDF_L(K),K=    1,  114) /
36955      &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
36956      &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
36957      &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
36958      &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
36959      &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
36960      &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
36961      &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
36962      &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
36963      &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
36964      &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
36965      &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
36966      &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
36967      &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
36968      &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
36969      &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
36970      &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
36971      &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
36972      &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
36973      &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
36974       DATA (XUDF_L(K),K=  115,  228) /
36975      &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
36976      &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
36977      &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
36978      &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
36979      &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
36980      &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
36981      &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
36982      &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
36983      &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
36984      &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
36985      &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
36986      &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
36987      &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
36988      &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
36989      &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
36990      &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
36991      &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
36992      &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
36993      &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
36994       DATA (XUDF_L(K),K=  229,  342) /
36995      &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
36996      &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
36997      &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
36998      &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
36999      &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
37000      &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
37001      &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
37002      &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
37003      &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
37004      &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
37005      &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
37006      &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
37007      &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
37008      &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
37009      &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
37010      &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
37011      &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
37012      &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
37013      &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
37014       DATA (XUDF_L(K),K=  343,  456) /
37015      &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
37016      &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
37017      &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
37018      &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
37019      &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
37020      &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
37021      &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
37022      &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
37023      &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
37024      &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
37025      &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
37026      &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
37027      &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
37028      &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
37029      &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
37030      &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
37031      &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
37032      &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
37033      &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
37034       DATA (XUDF_L(K),K=  457,  570) /
37035      &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
37036      &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
37037      &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
37038      &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
37039      &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
37040      &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
37041      &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
37042      &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
37043      &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
37044      &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
37045      &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
37046      &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
37047      &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
37048      &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
37049      &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
37050      &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
37051      &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
37052      &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
37053      &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
37054       DATA (XUDF_L(K),K=  571,  684) /
37055      &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
37056      &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
37057      &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
37058      &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
37059      &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
37060      &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
37061      &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
37062      &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
37063      &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
37064      &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
37065      &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
37066      &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
37067      &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
37068      &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
37069      &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
37070      &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
37071      &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
37072      &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
37073      &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
37074       DATA (XUDF_L(K),K=  685,  798) /
37075      &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
37076      &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
37077      &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
37078      &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
37079      &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
37080      &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
37081      &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
37082      &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
37083      &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
37084      &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
37085      &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
37086      &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
37087      &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
37088      &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
37089      &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
37090      &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
37091      &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
37092      &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
37093      &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
37094       DATA (XUDF_L(K),K=  799,  912) /
37095      &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
37096      &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
37097      &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
37098      &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
37099      &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
37100      &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
37101      &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
37102      &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
37103      &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
37104      &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
37105      &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
37106      &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
37107      &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37108      &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37109      &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37110      &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37111      &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37112      &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37113      &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37114       DATA (XUDF_L(K),K=  913, 1026) /
37115      &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37116      &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37117      &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37118      &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37119      &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37120      &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37121      &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37122      &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37123      &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37124      &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37125      &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37126      &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37127      &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37128      &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37129      &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37130      &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37131      &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37132      &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37133      &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37134       DATA (XUDF_L(K),K= 1027, 1140) /
37135      &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37136      &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37137      &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37138      &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37139      &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37140      &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37141      &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37142      &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37143      &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37144      &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37145      &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37146      &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37147      &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37148      &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37149      &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37150      &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37151      &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37152      &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37153      &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37154       DATA (XUDF_L(K),K= 1141, 1254) /
37155      &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37156      &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37157      &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37158      &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37159      &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37160      &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37161      &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37162      &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37163      &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37164      &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37165      &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37166      &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37167      &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37168      &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37169      &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37170      &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37171      &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37172      &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37173      &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37174       DATA (XUDF_L(K),K= 1255, 1368) /
37175      &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37176      &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37177      &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37178      &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37179      &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37180      &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37181      &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37182      &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37183      &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37184      &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37185      &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37186      &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37187      &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37188      &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37189      &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37190      &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37191      &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37192      &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37193      &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37194       DATA (XUDF_L(K),K= 1369, 1482) /
37195      &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37196      &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37197      &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37198      &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37199      &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37200      &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37201      &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37202      &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37203      &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37204      &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37205      &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37206      &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37207      &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37208      &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37209      &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37210      &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37211      &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37212      &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37213      &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37214       DATA (XUDF_L(K),K= 1483, 1596) /
37215      &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37216      &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37217      &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37218      &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37219      &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37220      &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37221      &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37222      &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37223      &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37224      &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37225      &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37226      &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37227      &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37228      &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37229      &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37230      &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37231      &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37232      &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37233      &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37234       DATA (XUDF_L(K),K= 1597, 1710) /
37235      &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37236      &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37237      &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37238      &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37239      &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37240      &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37241      &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37242      &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37243      &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37244      &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37245      &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37246      &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37247      &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37248      &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37249      &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37250      &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37251      &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37252      &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37253      &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37254       DATA (XUDF_L(K),K= 1711, 1824) /
37255      &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37256      &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37257      &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37258      &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37259      &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37260      &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37261      &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37262      &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37263      &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37264      &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37265      &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37266      &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37267      &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37268      &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37269      &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37270      &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37271      &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37272      &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37273      &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37274       DATA (XUDF_L(K),K= 1825, 1836) /
37275      &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37276      &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37277       DATA (XSF_L(K),K=    1,  114) /
37278      &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37279      &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37280      &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37281      &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37282      &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37283      &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37284      &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37285      &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37286      &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37287      &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37288      &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37289      &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37290      &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37291      &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37292      &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37293      &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37294      &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37295      &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37296      &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37297       DATA (XSF_L(K),K=  115,  228) /
37298      &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37299      &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37300      &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37301      &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37302      &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37303      &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37304      &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37305      &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37306      &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37307      &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37308      &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37309      &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37310      &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37311      &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37312      &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37313      &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37314      &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37315      &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37316      &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37317       DATA (XSF_L(K),K=  229,  342) /
37318      &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37319      &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37320      &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37321      &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37322      &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37323      &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37324      &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37325      &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37326      &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37327      &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37328      &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37329      &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37330      &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37331      &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37332      &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37333      &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37334      &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37335      &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37336      &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37337       DATA (XSF_L(K),K=  343,  456) /
37338      &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37339      &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37340      &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37341      &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37342      &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37343      &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37344      &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37345      &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37346      &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37347      &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37348      &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37349      &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37350      &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37351      &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37352      &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37353      &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37354      &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37355      &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37356      &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37357       DATA (XSF_L(K),K=  457,  570) /
37358      &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37359      &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37360      &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37361      &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37362      &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37363      &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37364      &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37365      &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37366      &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37367      &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37368      &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37369      &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37370      &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37371      &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37372      &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37373      &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37374      &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37375      &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37376      &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37377       DATA (XSF_L(K),K=  571,  684) /
37378      &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37379      &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37380      &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37381      &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37382      &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37383      &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37384      &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37385      &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37386      &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37387      &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37388      &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37389      &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37390      &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37391      &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37392      &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37393      &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37394      &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37395      &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37396      &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37397       DATA (XSF_L(K),K=  685,  798) /
37398      &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37399      &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37400      &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37401      &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37402      &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37403      &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37404      &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37405      &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37406      &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37407      &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37408      &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37409      &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37410      &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37411      &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37412      &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37413      &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37414      &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37415      &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37416      &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37417       DATA (XSF_L(K),K=  799,  912) /
37418      &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37419      &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37420      &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37421      &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37422      &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37423      &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37424      &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37425      &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37426      &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37427      &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37428      &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37429      &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37430      &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37431      &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37432      &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37433      &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37434      &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37435      &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37436      &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37437       DATA (XSF_L(K),K=  913, 1026) /
37438      &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37439      &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37440      &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37441      &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37442      &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37443      &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37444      &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37445      &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37446      &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37447      &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37448      &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37449      &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37450      &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37451      &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37452      &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37453      &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37454      &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37455      &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37456      &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37457       DATA (XSF_L(K),K= 1027, 1140) /
37458      &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37459      &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37460      &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37461      &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37462      &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37463      &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37464      &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37465      &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37466      &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37467      &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37468      &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37469      &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37470      &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37471      &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37472      &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37473      &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37474      &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37475      &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37476      &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37477       DATA (XSF_L(K),K= 1141, 1254) /
37478      &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37479      &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37480      &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37481      &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37482      &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37483      &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37484      &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37485      &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37486      &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37487      &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37488      &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37489      &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37490      &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37491      &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37492      &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37493      &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37494      &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37495      &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37496      &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37497       DATA (XSF_L(K),K= 1255, 1368) /
37498      &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37499      &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37500      &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37501      &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37502      &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37503      &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37504      &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37505      &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37506      &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37507      &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37508      &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37509      &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37510      &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37511      &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37512      &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37513      &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37514      &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37515      &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37516      &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37517       DATA (XSF_L(K),K= 1369, 1482) /
37518      &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37519      &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37520      &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37521      &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37522      &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37523      &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37524      &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37525      &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37526      &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37527      &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37528      &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37529      &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37530      &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37531      &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37532      &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37533      &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37534      &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37535      &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37536      &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37537       DATA (XSF_L(K),K= 1483, 1596) /
37538      &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37539      &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37540      &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37541      &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37542      &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37543      &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37544      &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37545      &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37546      &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37547      &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37548      &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37549      &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37550      &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37551      &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37552      &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37553      &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37554      &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37555      &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37556      &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37557       DATA (XSF_L(K),K= 1597, 1710) /
37558      &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37559      &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37560      &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37561      &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37562      &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37563      &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37564      &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37565      &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37566      &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37567      &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37568      &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37569      &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37570      &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37571      &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37572      &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37573      &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37574      &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37575      &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37576      &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37577       DATA (XSF_L(K),K= 1711, 1824) /
37578      &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37579      &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37580      &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37581      &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37582      &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37583      &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37584      &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37585      &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37586      &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37587      &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37588      &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37589      &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37590      &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37591      &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37592      &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37593      &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37594      &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37595      &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37596      &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37597       DATA (XSF_L(K),K= 1825, 1836) /
37598      &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37599      &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37600       DATA (XGF_L(K),K=    1,  114) /
37601      &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37602      &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37603      &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37604      &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37605      &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37606      &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37607      &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37608      &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37609      &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37610      &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37611      &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37612      &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37613      &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37614      &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37615      &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37616      &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37617      &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37618      &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37619      &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37620       DATA (XGF_L(K),K=  115,  228) /
37621      &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37622      &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37623      &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37624      &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37625      &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37626      &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37627      &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37628      &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37629      &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37630      &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37631      &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37632      &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37633      &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37634      &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37635      &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37636      &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37637      &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37638      &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37639      &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37640       DATA (XGF_L(K),K=  229,  342) /
37641      &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37642      &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37643      &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37644      &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37645      &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37646      &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37647      &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37648      &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37649      &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37650      &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37651      &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37652      &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37653      &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37654      &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37655      &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37656      &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37657      &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37658      &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37659      &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37660       DATA (XGF_L(K),K=  343,  456) /
37661      &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37662      &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37663      &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37664      &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
37665      &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
37666      &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
37667      &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
37668      &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
37669      &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
37670      &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
37671      &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
37672      &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
37673      &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
37674      &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
37675      &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
37676      &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
37677      &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
37678      &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
37679      &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
37680       DATA (XGF_L(K),K=  457,  570) /
37681      &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
37682      &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
37683      &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
37684      &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
37685      &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
37686      &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
37687      &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
37688      &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
37689      &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
37690      &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
37691      &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
37692      &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
37693      &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
37694      &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
37695      &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
37696      &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
37697      &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
37698      &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
37699      &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
37700       DATA (XGF_L(K),K=  571,  684) /
37701      &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
37702      &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
37703      &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
37704      &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
37705      &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
37706      &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
37707      &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
37708      &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
37709      &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
37710      &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
37711      &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
37712      &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
37713      &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
37714      &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
37715      &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
37716      &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
37717      &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
37718      &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
37719      &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
37720       DATA (XGF_L(K),K=  685,  798) /
37721      &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
37722      &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
37723      &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
37724      &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
37725      &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
37726      &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
37727      &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
37728      &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
37729      &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
37730      &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
37731      &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
37732      &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
37733      &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
37734      &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
37735      &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
37736      &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
37737      &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
37738      &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
37739      &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
37740       DATA (XGF_L(K),K=  799,  912) /
37741      &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
37742      &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
37743      &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
37744      &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
37745      &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
37746      &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
37747      &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
37748      &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
37749      &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
37750      &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
37751      &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
37752      &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
37753      &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
37754      &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
37755      &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
37756      &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
37757      &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
37758      &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
37759      &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
37760       DATA (XGF_L(K),K=  913, 1026) /
37761      &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
37762      &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
37763      &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
37764      &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
37765      &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
37766      &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
37767      &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
37768      &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
37769      &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
37770      &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
37771      &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
37772      &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
37773      &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
37774      &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
37775      &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
37776      &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
37777      &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
37778      &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
37779      &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
37780       DATA (XGF_L(K),K= 1027, 1140) /
37781      &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
37782      &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
37783      &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
37784      &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
37785      &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
37786      &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
37787      &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
37788      &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
37789      &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
37790      &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
37791      &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
37792      &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
37793      &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
37794      &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
37795      &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
37796      &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
37797      &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
37798      &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
37799      &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
37800       DATA (XGF_L(K),K= 1141, 1254) /
37801      &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
37802      &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
37803      &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
37804      &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
37805      &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
37806      &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
37807      &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
37808      &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
37809      &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
37810      &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
37811      &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
37812      &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
37813      &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
37814      &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
37815      &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
37816      &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
37817      &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
37818      &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
37819      &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
37820       DATA (XGF_L(K),K= 1255, 1368) /
37821      &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
37822      &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
37823      &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
37824      &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
37825      &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
37826      &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
37827      &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
37828      &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
37829      &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
37830      &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
37831      &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
37832      &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
37833      &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
37834      &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
37835      &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
37836      &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
37837      &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
37838      &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
37839      &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
37840       DATA (XGF_L(K),K= 1369, 1482) /
37841      &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
37842      &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
37843      &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
37844      &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
37845      &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
37846      &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
37847      &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
37848      &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
37849      &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
37850      &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
37851      &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
37852      &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
37853      &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
37854      &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
37855      &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
37856      &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
37857      &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
37858      &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
37859      &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
37860       DATA (XGF_L(K),K= 1483, 1596) /
37861      &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
37862      &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
37863      &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
37864      &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
37865      &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
37866      &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
37867      &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
37868      &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
37869      &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
37870      &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
37871      &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
37872      &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
37873      &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
37874      &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
37875      &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
37876      &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
37877      &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
37878      &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
37879      &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
37880       DATA (XGF_L(K),K= 1597, 1710) /
37881      &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
37882      &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
37883      &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
37884      &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
37885      &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
37886      &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
37887      &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
37888      &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
37889      &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
37890      &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
37891      &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
37892      &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
37893      &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
37894      &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
37895      &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
37896      &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
37897      &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
37898      &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
37899      &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
37900       DATA (XGF_L(K),K= 1711, 1824) /
37901      &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
37902      &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
37903      &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
37904      &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
37905      &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
37906      &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
37907      &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
37908      &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
37909      &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
37910      &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
37911      &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
37912      &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
37913      &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
37914      &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
37915      &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
37916      &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
37917      &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
37918      &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
37919      &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
37920       DATA (XGF_L(K),K= 1825, 1836) /
37921      &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
37922      &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
37923
37924 *
37925       X = Xinp
37926 *...CHECK OF X AND Q2 VALUES :
37927       IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37928 *        WRITE(LO,91) X
37929   91     FORMAT (2X,'GRV98: x out of range',1p,E12.4)
37930          X = 0.99D-9
37931 *        STOP
37932       ENDIF
37933
37934       Q2 = Q2inp
37935       IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37936 *        WRITE(LO,92) Q2
37937   92     FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
37938          Q2 = 0.99E6
37939 *        STOP
37940       ENDIF
37941
37942 *
37943 *...INTERPOLATION :
37944       NA(1) = NX
37945       NA(2) = NQ
37946       XT(1) = DLOG(X)
37947       XT(2) = DLOG(Q2)
37948       X1 = 1.- X
37949       XV = X**0.5
37950       XS = X**(-0.2)
37951       UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37952       DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37953       DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37954       UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37955       US = 0.5 * (UD - DE)
37956       DS = 0.5 * (UD + DE)
37957       SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF)  * X1**7 * XS
37958       GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF)  * X1**5 * XS
37959
37960       END
37961
37962 CDECK  ID>, PHO_DOR98SC
37963       SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
37964 C***********************************************************************
37965 C
37966 C   GRV98 parton densities, leading order set
37967 C
37968 C                  For a detailed explanation see
37969 C                   M. Glueck, E. Reya, A. Vogt :
37970 C        hep-ph/9806404  =  DO-TH 98/07  =  WUE-ITP-98-019
37971 C                  (To appear in Eur. Phys. J. C)
37972 C
37973 C   interpolation routine based on the original GRV98PA routine,
37974 C   adapted to define interpolation table as DATA statements
37975 C
37976 C                                                   (R.Engel, 09/98)
37977 C
37978 C   CAUTION: this is a version with gluon shadowing corrections
37979 C                                                   (R.Engel, 09/99)
37980 C
37981 C
37982 C   INPUT:   X  =  Bjorken-x        (between  1.E-9 and 1.)
37983 C            Q2 =  scale in GeV**2  (between  0.8 and 1.E6)
37984 C
37985 C   OUTPUT:  UV = u - u(bar),  DV = d - d(bar),  US = u(bar),
37986 C            DS = d(bar),  SS = s = s(bar),  GL = gluon.
37987 C            Always x times the distribution is returned.
37988 C
37989 C******************************************************i****************
37990       IMPLICIT DOUBLE PRECISION (A-H, O-Z)
37991       SAVE
37992
37993 C  input/output channels
37994       INTEGER LI,LO
37995       COMMON /POINOU/ LI,LO
37996
37997       PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
37998       DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
37999      1          XSF(NX,NQ), XGF(NX,NQ),
38000      2          XT(NARG), NA(NARG), ARRF(NX+NQ)
38001
38002       DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
38003      &  XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
38004
38005       EQUIVALENCE (XUVF(1,1),XUVF_L(1))
38006       EQUIVALENCE (XDVF(1,1),XDVF_L(1))
38007       EQUIVALENCE (XDEF(1,1),XDEF_L(1))
38008       EQUIVALENCE (XUDF(1,1),XUDF_L(1))
38009       EQUIVALENCE (XSF(1,1),XSF_L(1))
38010       EQUIVALENCE (XGF(1,1),XGF_L(1))
38011
38012 *#################### data statements for shadowed LO PDF ##############
38013 C  ... deleted ...
38014 *#######################################################################
38015
38016       X = Xinp
38017 *...CHECK OF X AND Q2 VALUES :
38018       IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
38019 *        WRITE(LO,91) X
38020   91     FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
38021          X = 0.99D-9
38022 *        STOP
38023       ENDIF
38024
38025       Q2 = Q2inp
38026       IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
38027 *        WRITE(LO,92) Q2
38028   92     FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
38029          Q2 = 0.99E6
38030 *        STOP
38031       ENDIF
38032
38033 *
38034 *...INTERPOLATION :
38035       NA(1) = NX
38036       NA(2) = NQ
38037       XT(1) = DLOG(X)
38038       XT(2) = DLOG(Q2)
38039       X1 = 1.- X
38040       XV = X**0.5
38041       XS = X**(-0.2)
38042       UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
38043       DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
38044       DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
38045       UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
38046       US = 0.5 * (UD - DE)
38047       DS = 0.5 * (UD + DE)
38048       SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF)  * X1**7 * XS
38049       GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF)  * X1**5 * XS
38050
38051       END
38052
38053 CDECK  ID>, PHO_DOR94LO
38054 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38055 *                                                                 *
38056 *    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     *
38057 *                                                                 *
38058 *                         1994 UPDATE                             *
38059 *                                                                 *
38060 *                 FOR A DETAILED EXPLANATION SEE                  *
38061 *                   M. GLUECK, E.REYA, A.VOGT :                   *
38062 *                   DO-TH 94/24  =  DESY 94-206                   *
38063 *                    (TO APPEAR IN Z. PHYS. C)                    *
38064 *                                                                 *
38065 *   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
38066 *        Q**2 / GEV**2  BETWEEN   0.4   AND  1.E6                 *
38067 *             X         BETWEEN  1.E-5  AND   1.                  *
38068 *   LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION   *
38069 *   IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT.              *
38070 *                                                                 *
38071 *   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
38072 *                   M(C)  =  1.5,  M(B)  =  4.5                   *
38073 *   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
38074 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38075 *             LAMBDA(5)  =  0.153,                                *
38076 *      NLO :  LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38077 *             LAMBDA(5)  =  0.131.                                *
38078 *   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
38079 *   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
38080 *   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
38081 *   IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991   *
38082 *   GRV PARAMETRIZATION.                                          *
38083 *                                                                 *
38084 *   NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME    *
38085 *   (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI),  *
38086 *   THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO".   *
38087 *                                                                 *
38088 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38089 *
38090 *...INPUT PARAMETERS :
38091 *
38092 *    X   = MOMENTUM FRACTION
38093 *    Q2  = SCALE Q**2 IN GEV**2
38094 *
38095 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
38096 *
38097 *    UV  = U(VAL) = U - U(BAR)
38098 *    DV  = D(VAL) = D - D(BAR)
38099 *    DEL = D(BAR) - U(BAR)
38100 *    UDB = U(BAR) + D(BAR)
38101 *    SB  = S = S(BAR)
38102 *    GL  = GLUON
38103 *
38104 *...LO PARAMETRIZATION :
38105 *
38106       SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38107       IMPLICIT DOUBLE PRECISION (A - Z)
38108       SAVE
38109
38110        MU2  = 0.23
38111        LAM2 = 0.2322 * 0.2322
38112        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38113        DS = SQRT (S)
38114        S2 = S * S
38115        S3 = S2 * S
38116 *...UV :
38117        NU  =  2.284 + 0.802 * S + 0.055 * S2
38118        AKU =  0.590 - 0.024 * S
38119        BKU =  0.131 + 0.063 * S
38120        AU  = -0.449 - 0.138 * S - 0.076 * S2
38121        BU  =  0.213 + 2.669 * S - 0.728 * S2
38122        CU  =  8.854 - 9.135 * S + 1.979 * S2
38123        DU  =  2.997 + 0.753 * S - 0.076 * S2
38124        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38125 *...DV :
38126        ND  =  0.371 + 0.083 * S + 0.039 * S2
38127        AKD =  0.376
38128        BKD =  0.486 + 0.062 * S
38129        AD  = -0.509 + 3.310 * S - 1.248 * S2
38130        BD  =  12.41 - 10.52 * S + 2.267 * S2
38131        CD  =  6.373 - 6.208 * S + 1.418 * S2
38132        DD  =  3.691 + 0.799 * S - 0.071 * S2
38133        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38134 *...DEL :
38135        NE  =  0.082 + 0.014 * S + 0.008 * S2
38136        AKE =  0.409 - 0.005 * S
38137        BKE =  0.799 + 0.071 * S
38138        AE  = -38.07 + 36.13 * S - 0.656 * S2
38139        BE  =  90.31 - 74.15 * S + 7.645 * S2
38140        CE  =  0.0
38141        DE  =  7.486 + 1.217 * S - 0.159 * S2
38142        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38143 *...UDB :
38144        ALX =  1.451
38145        BEX =  0.271
38146        AKX =  0.410 - 0.232 * S
38147        BKX =  0.534 - 0.457 * S
38148        AGX =  0.890 - 0.140 * S
38149        BGX = -0.981
38150        CX  =  0.320 + 0.683 * S
38151        DX  =  4.752 + 1.164 * S + 0.286 * S2
38152        EX  =  4.119 + 1.713 * S
38153        ESX =  0.682 + 2.978 * S
38154        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38155 *...SB :
38156        ALS =  0.914
38157        BES =  0.577
38158        AKS =  1.798 - 0.596 * S
38159        AS  = -5.548 + 3.669 * DS - 0.616 * S
38160        BS  =  18.92 - 16.73 * DS + 5.168 * S
38161        DST =  6.379 - 0.350 * S  + 0.142 * S2
38162        EST =  3.981 + 1.638 * S
38163        ESS =  6.402
38164        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38165 *...GL :
38166        ALG =  0.524
38167        BEG =  1.088
38168        AKG =  1.742 - 0.930 * S
38169        BKG =        - 0.399 * S2
38170        AG  =  7.486 - 2.185 * S
38171        BG  =  16.69 - 22.74 * S  + 5.779 * S2
38172        CG  = -25.59 + 29.71 * S  - 7.296 * S2
38173        DG  =  2.792 + 2.215 * S  + 0.422 * S2 - 0.104 * S3
38174        EG  =  0.807 + 2.005 * S
38175        ESG =  3.841 + 0.316 * S
38176        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38177
38178        END
38179
38180 *
38181 *...NLO PARAMETRIZATION (MS(BAR)) :
38182 *
38183 CDECK  ID>, PHO_DOR94HO
38184       SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38185       IMPLICIT DOUBLE PRECISION (A - Z)
38186       SAVE
38187
38188        MU2  = 0.34
38189        LAM2 = 0.248 * 0.248
38190        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38191        DS = SQRT (S)
38192        S2 = S * S
38193        S3 = S2 * S
38194 *...UV :
38195        NU  =  1.304 + 0.863 * S
38196        AKU =  0.558 - 0.020 * S
38197        BKU =          0.183 * S
38198        AU  = -0.113 + 0.283 * S - 0.321 * S2
38199        BU  =  6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38200        CU  =  7.771 - 10.09 * S + 2.630 * S2
38201        DU  =  3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38202        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38203 *...DV :
38204        ND  =  0.102 - 0.017 * S + 0.005 * S2
38205        AKD =  0.270 - 0.019 * S
38206        BKD =  0.260
38207        AD  =  2.393 + 6.228 * S - 0.881 * S2
38208        BD  =  46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38209        CD  =  17.83 - 53.47 * S + 21.24 * S2
38210        DD  =  4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38211        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38212 *...DEL :
38213        NE  =  0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38214        AKE =  0.409 - 0.007 * S
38215        BKE =  0.782 + 0.082 * S
38216        AE  = -29.65 + 26.49 * S + 5.429 * S2
38217        BE  =  90.20 - 74.97 * S + 4.526 * S2
38218        CE  =  0.0
38219        DE  =  8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38220        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38221 *...UDB :
38222        ALX =  0.877
38223        BEX =  0.561
38224        AKX =  0.275
38225        BKX =  0.0
38226        AGX =  0.997
38227        BGX =  3.210 - 1.866 * S
38228        CX  =  7.300
38229        DX  =  9.010 + 0.896 * DS + 0.222 * S2
38230        EX  =  3.077 + 1.446 * S
38231        ESX =  3.173 - 2.445 * DS + 2.207 * S
38232        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38233 *...SB :
38234        ALS =  0.756
38235        BES =  0.216
38236        AKS =  1.690 + 0.650 * DS - 0.922 * S
38237        AS  = -4.329 + 1.131 * S
38238        BS  =  9.568 - 1.744 * S
38239        DST =  9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38240        EST =  3.031 + 1.639 * S
38241        ESS =  5.837 + 0.815 * S
38242        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38243 *...GL :
38244        ALG =  1.014
38245        BEG =  1.738
38246        AKG =  1.724 + 0.157 * S
38247        BKG =  0.800 + 1.016 * S
38248        AG  =  7.517 - 2.547 * S
38249        BG  =  34.09 - 52.21 * DS + 17.47 * S
38250        CG  =  4.039 + 1.491 * S
38251        DG  =  3.404 + 0.830 * S
38252        EG  = -1.112 + 3.438 * S  - 0.302 * S2
38253        ESG =  3.256 - 0.436 * S
38254        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38255
38256        END
38257
38258 CDECK  ID>, PHO_DOR94DI
38259 *
38260 *...NLO PARAMETRIZATION (DIS) :
38261 *
38262       SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38263       IMPLICIT DOUBLE PRECISION (A - Z)
38264       SAVE
38265
38266        MU2  = 0.34
38267        LAM2 = 0.248 * 0.248
38268        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38269        DS = SQRT (S)
38270        S2 = S * S
38271        S3 = S2 * S
38272 *...UV :
38273        NU  =  2.484 + 0.116 * S + 0.093 * S2
38274        AKU =  0.563 - 0.025 * S
38275        BKU =  0.054 + 0.154 * S
38276        AU  = -0.326 - 0.058 * S - 0.135 * S2
38277        BU  = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38278        CU  =  11.52 - 12.99 * S + 3.161 * S2
38279        DU  =  2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38280        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38281 *...DV :
38282        ND  =  0.156 - 0.017 * S
38283        AKD =  0.299 - 0.022 * S
38284        BKD =  0.259 - 0.015 * S
38285        AD  =  3.445 + 1.278 * S + 0.326 * S2
38286        BD  = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38287        CD  =  55.45 - 69.92 * S + 20.78 * S2
38288        DD  =  3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38289        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38290 *...DEL :
38291        NE  =  0.099 + 0.019 * S + 0.002 * S2
38292        AKE =  0.419 - 0.013 * S
38293        BKE =  1.064 - 0.038 * S
38294        AE  = -44.00 + 98.70 * S - 14.79 * S2
38295        BE  =  28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38296        CE  =  84.57 - 108.8 * S + 31.52 * S2
38297        DE  =  7.469 + 2.480 * S - 0.866 * S2
38298        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38299 *...UDB :
38300        ALX =  1.215
38301        BEX =  0.466
38302        AKX =  0.326 + 0.150 * S
38303        BKX =  0.956 + 0.405 * S
38304        AGX =  0.272
38305        BGX =  3.794 - 2.359 * DS
38306        CX  =  2.014
38307        DX  =  7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38308        EX  =  3.049 + 1.597 * S
38309        ESX =  4.396 - 4.594 * DS + 3.268 * S
38310        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38311 *...SB :
38312        ALS =  0.175
38313        BES =  0.344
38314        AKS =  1.415 - 0.641 * DS
38315        AS  =  0.580 - 9.763 * DS + 6.795 * S  - 0.558 * S2
38316        BS  =  5.617 + 5.709 * DS - 3.972 * S
38317        DST =  13.78 - 9.581 * S  + 5.370 * S2 - 0.996 * S3
38318        EST =  4.546 + 0.372 * S2
38319        ESS =  5.053 - 1.070 * S  + 0.805 * S2
38320        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38321 *...GL :
38322        ALG =  1.258
38323        BEG =  1.846
38324        AKG =  2.423
38325        BKG =  2.427 + 1.311 * S  - 0.153 * S2
38326        AG  =  25.09 - 7.935 * S
38327        BG  = -14.84 - 124.3 * DS + 72.18 * S
38328        CG  =  590.3 - 173.8 * S
38329        DG  =  5.196 + 1.857 * S
38330        EG  = -1.648 + 3.988 * S  - 0.432 * S2
38331        ESG =  3.232 - 0.542 * S
38332        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38333
38334        END
38335
38336 *
38337 *...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38338 *
38339 CDECK  ID>, PHO_DOR94FV
38340       DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38341       IMPLICIT DOUBLE PRECISION (A - Z)
38342       SAVE
38343
38344        DX = SQRT (X)
38345        PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38346
38347       END
38348
38349 CDECK  ID>, PHO_DOR94FW
38350       DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38351      &                                      A,B,C,D,E,ES)
38352       IMPLICIT DOUBLE PRECISION (A - Z)
38353       SAVE
38354
38355       LX = LOG (1./X)
38356       PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38357      1     * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38358
38359       END
38360
38361 CDECK  ID>, PHO_DOR94FS
38362       DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38363       IMPLICIT DOUBLE PRECISION (A - Z)
38364       SAVE
38365
38366       DX = SQRT (X)
38367       LX = LOG (1./X)
38368       PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38369      1      * DEXP (-E + SQRT (ES * S**BE * LX))
38370
38371       END
38372
38373 CDECK  ID>, PHO_DOR92LO
38374 *
38375 *
38376 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38377 *                                                                 *
38378 *    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     *
38379 *                                                                 *
38380 *                 FOR A DETAILED EXPLANATION SEE :                *
38381 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07             *
38382 *                                                                 *
38383 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38384 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38385 *   / HO) AND  1.E8 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38386 *   REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG-   *
38387 *   LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT.  *
38388 *                                                                 *
38389 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38390 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38391 *                                                                 *
38392 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38393 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38394 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38395 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38396 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38397 *                                                                 *
38398 *   HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL.  *
38399 *                                                                 *
38400 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38401 C
38402       SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38403       IMPLICIT DOUBLE PRECISION (A - Z)
38404       SAVE
38405
38406        MU2  = 0.25
38407        LAM2 = 0.232 * 0.232
38408        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38409        S2 = S * S
38410        S3 = S2 * S
38411 C...X * (UV + DV) :
38412        NUD  = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38413        AKUD = 0.326
38414        AGUD = -1.97 +  6.74 * S -  1.96 * S2
38415        BUD  =  24.4 -  20.7 * S +  4.08 * S2
38416        DUD  =  2.86 +  0.70 * S -  0.02 * S2
38417        UDV  = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38418 C...X * DV :
38419        ND  = 0.579 + 0.283 * S + 0.047 * S2
38420        AKD = 0.523 - 0.015 * S
38421        AGD =  2.22 -  0.59 * S -  0.27 * S2
38422        BD  =  5.95 -  6.19 * S +  1.55 * S2
38423        DD  =  3.57 +  0.94 * S -  0.16 * S2
38424        DV  = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38425 C...X * G :
38426        ALG =  0.558
38427        BEG =  1.218
38428        AKG =   1.00 -  0.17 * S
38429        BKG =   0.0
38430        AGG =   0.0  + 4.879 * S - 1.383 * S2
38431        BGG =  25.92 - 28.97 * S + 5.596 * S2
38432        CG  = -25.69 + 23.68 * S - 1.975 * S2
38433        DG  =  2.537 + 1.718 * S + 0.353 * S2
38434        EG  =  0.595 + 2.138 * S
38435        ESG =  4.066
38436        GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38437 C...X * UBAR = X * DBAR :
38438        ALU =  1.396
38439        BEU =  1.331
38440        AKU =  0.412 - 0.171 * S
38441        BKU =  0.566 - 0.496 * S
38442        AGU =  0.363
38443        BGU = -1.196
38444        CU  =  1.029 + 1.785 * S - 0.459 * S2
38445        DU  =  4.696 + 2.109 * S
38446        EU  =  3.838 + 1.944 * S
38447        ESU =  2.845
38448        UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38449 C...X * SBAR = X * S :
38450        SS  =   0.0
38451        ALS =  0.803
38452        BES =  0.563
38453        AKS =  2.082 - 0.577 * S
38454        AGS = -3.055 + 1.024 * S **  0.67
38455        BS  =   27.4 -  20.0 * S ** 0.154
38456        DS  =   6.22
38457        EST =   4.33 + 1.408 * S
38458        ESS =   8.27 - 0.437 * S
38459        SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38460 C...X * CBAR = X * C :
38461        SC  =  0.888
38462        ALC =   1.01
38463        BEC =   0.37
38464        AKC =   0.0
38465        AGC =   0.0
38466        BC  =   4.24 - 0.804 * S
38467        DC  =   3.46 + 1.076 * S
38468        EC  =   4.61 + 1.490 * S
38469        ESC =  2.555 + 1.961 * S
38470        CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38471 C...X * BBAR = X * B :
38472        SBO =  1.351
38473        ALB =   1.00
38474        BEB =   0.51
38475        AKB =   0.0
38476        AGB =   0.0
38477        BBO =  1.848
38478        DB  =  2.929 + 1.396 * S
38479        EB  =   4.71 + 1.514 * S
38480        ESB =   4.02 + 1.239 * S
38481        BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38482
38483       END
38484
38485 CDECK  ID>, PHO_DOR92HO
38486       SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38487       IMPLICIT DOUBLE PRECISION (A - Z)
38488       SAVE
38489
38490        MU2  = 0.3
38491        LAM2 = 0.248 * 0.248
38492        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38493        DS = SQRT (S)
38494        S2 = S * S
38495        S3 = S2 * S
38496 C...X * (UV + DV) :
38497        NUD  = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38498        AKUD = 0.285
38499        AGUD = -2.28 + 15.73 * S -  4.58 * S2
38500        BUD  =  56.7 -  53.6 * S + 11.21 * S2
38501        DUD  =  3.17 +  1.17 * S -  0.47 * S2 +  0.09 * S3
38502        UDV  = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38503 C...X * DV :
38504        ND  = 0.459 + 0.315 * DS + 0.515 * S
38505        AKD = 0.624              - 0.031 * S
38506        AGD =  8.13 -  6.77 * DS +  0.46 * S
38507        BD  =  6.59 - 12.83 * DS +  5.65 * S
38508        DD  =  3.98              +  1.04 * S  -  0.34 * S2
38509        DV  = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38510 C...X * G :
38511        ALG =  1.128
38512        BEG =  1.575
38513        AKG =  0.323 + 1.653 * S
38514        BKG =  0.811 + 2.044 * S
38515        AGG =   0.0  + 1.963 * S - 0.519 * S2
38516        BGG =  0.078 +  6.24 * S
38517        CG  =  30.77 - 24.19 * S
38518        DG  =  3.188 + 0.720 * S
38519        EG  = -0.881 + 2.687 * S
38520        ESG =  2.466
38521        GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38522 C...X * UBAR = X * DBAR :
38523        ALU =  0.594
38524        BEU =  0.614
38525        AKU =  0.636 - 0.084 * S
38526        BKU =   0.0
38527        AGU =  1.121 - 0.193 * S
38528        BGU =  0.751 - 0.785 * S
38529        CU  =   8.57 - 1.763 * S
38530        DU  =  10.22 + 0.668 * S
38531        EU  =  3.784 + 1.280 * S
38532        ESU =  1.808 + 0.980 * S
38533        UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38534 C...X * SBAR = X * S :
38535        SS  =   0.0
38536        ALS =  0.756
38537        BES =  0.101
38538        AKS =  2.942 - 1.016 * S
38539        AGS =  -4.60 + 1.167 * S
38540        BS  =   9.31 - 1.324 * S
38541        DS  =  11.49 - 1.198 * S + 0.053 * S2
38542        EST =  2.630 + 1.729 * S
38543        ESS =   8.12
38544        SB  = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38545 C...X * CBAR = X * C :
38546        SC  =  0.820
38547        ALC =   0.98
38548        BEC =   0.0
38549        AKC = -0.625 - 0.523 * S
38550        AGC =   0.0
38551        BC  =  1.896 + 1.616 * S
38552        DC  =   4.12 + 0.683 * S
38553        EC  =   4.36 + 1.328 * S
38554        ESC =  0.677 + 0.679 * S
38555        CB  = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38556 C...X * BBAR = X * B :
38557        SBO =  1.297
38558        ALB =   0.99
38559        BEB =   0.0
38560        AKB =   0.0  - 0.193 * S
38561        AGB =   0.0
38562        BBO =   0.0
38563        DB  =  3.447 + 0.927 * S
38564        EB  =   4.68 + 1.259 * S
38565        ESB =  1.892 + 2.199 * S
38566        BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38567
38568       END
38569
38570 CDECK  ID>, PHO_DOR92FV
38571       DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38572       IMPLICIT DOUBLE PRECISION (A - Z)
38573       SAVE
38574        DX = SQRT (X)
38575        PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38576
38577       END
38578
38579 CDECK  ID>, PHO_DOR92FW
38580       DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38581      &                                      AL,BE,AK,BK,AG,BG,C,D,E,ES)
38582       IMPLICIT DOUBLE PRECISION (A - Z)
38583       SAVE
38584        LX = LOG (1./X)
38585        PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38586      1      * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38587
38588       END
38589
38590 CDECK  ID>, PHO_DOR92FS
38591       DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38592       IMPLICIT DOUBLE PRECISION (A - Z)
38593       SAVE
38594
38595        DX = SQRT (X)
38596        LX = LOG (1./X)
38597        IF (S .LE. ST) THEN
38598          PHO_DOR92FS = 0.D0
38599        ELSE
38600          PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38601      1          * EXP (-E + SQRT (ES * S**BE * LX))
38602        END IF
38603
38604       END
38605
38606 CDECK  ID>, PHO_DORPLO
38607 *
38608 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38609 *                                                                 *
38610 *         G R V - P I O N - P A R A M E T R I Z A T I O N S       *
38611 *                                                                 *
38612 *                 FOR A DETAILED EXPLANATION SEE :                *
38613 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16             *
38614 *                                                                 *
38615 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38616 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38617 *   / HO) AND  1.E8 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38618 *   REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG-   *
38619 *   LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT.  *
38620 *                                                                 *
38621 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38622 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38623 *                                                                 *
38624 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38625 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38626 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38627 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38628 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38629 *                                                                 *
38630 *   HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL.  *
38631 *                                                                 *
38632 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38633 C
38634       SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38635       IMPLICIT DOUBLE PRECISION (A - Z)
38636       SAVE
38637
38638        MU2  = 0.25
38639        LAM2 = 0.232 * 0.232
38640        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38641        DS = SQRT (S)
38642        S2 = S * S
38643 C...X * VALENCE :
38644        NV  =  0.519 + 0.180 * S - 0.011 * S2
38645        AKV =  0.499 - 0.027 * S
38646        AGV =  0.381 - 0.419 * S
38647        DV  =  0.367 + 0.563 * S
38648        VAP =  PHO_DORFVP (X, NV, AKV, AGV, DV)
38649 C...X * GLUON :
38650        ALG =  0.599
38651        BEG =  1.263
38652        AKG =  0.482 + 0.341 * DS
38653        BKG =   0.0
38654        AGG =  0.678 + 0.877 * S  - 0.175 * S2
38655        BGG =  0.338 - 1.597 * S
38656        CG  =   0.0  - 0.233 * S  + 0.406 * S2
38657        DG  =  0.390 + 1.053 * S
38658        EG  =  0.618 + 2.070 * S
38659        ESG =  3.676
38660        GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38661 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38662        SL  =   0.0
38663        ALS =   0.55
38664        BES =   0.56
38665        AKS =  2.538 - 0.763 * S
38666        AGS = -0.748
38667        BS  =  0.313 + 0.935 * S
38668        DS  =  3.359
38669        EST =  4.433 + 1.301 * S
38670        ESS =   9.30 - 0.887 * S
38671        QBP =  PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38672 C...X * CBAR = X * C :
38673        SC  =  0.888
38674        ALC =   1.02
38675        BEC =   0.39
38676        AKC =   0.0
38677        AGC =   0.0
38678        BC  =  1.008
38679        DC  =  1.208 + 0.771 * S
38680        EC  =   4.40 + 1.493 * S
38681        ESC =  2.032 + 1.901 * S
38682        CBP =  PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38683 C...X * BBAR = X * B :
38684        SBO =  1.351
38685        ALB =   1.03
38686        BEB =   0.39
38687        AKB =   0.0
38688        AGB =   0.0
38689        BBO =   0.0
38690        DB  =  0.697 + 0.855 * S
38691        EB  =   4.51 + 1.490 * S
38692        ESB =  3.056 + 1.694 * S
38693        BBP =  PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38694
38695        END
38696
38697 CDECK  ID>, PHO_DORPHO
38698       SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38699       IMPLICIT DOUBLE PRECISION (A - Z)
38700       SAVE
38701
38702        MU2  = 0.3
38703        LAM2 = 0.248 * 0.248
38704        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38705        DS = SQRT (S)
38706        S2 = S * S
38707 C...X * VALENCE :
38708        NV  =  0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
38709        AKV =  0.505 - 0.033 * S
38710        AGV =  0.748 - 0.669 * DS - 0.133 * S
38711        DV  =  0.365 + 0.197 * DS + 0.394 * S
38712        VAP =  PHO_DORFVP (X, NV, AKV, AGV, DV)
38713 C...X * GLUON :
38714        ALG =  1.096
38715        BEG =  1.371
38716        AKG =  0.437 - 0.689 * DS
38717        BKG = -0.631
38718        AGG =  1.324 - 0.441 * DS - 0.130 * S
38719        BGG = -0.955 + 0.259 * S
38720        CG  =  1.075 - 0.302 * S
38721        DG  =  1.158 + 1.229 * S
38722        EG  =   0.0  + 2.510 * S
38723        ESG =  2.604 + 0.165 * S
38724        GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38725 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38726        SL  =   0.0
38727        ALS =   0.85
38728        BES =   0.96
38729        AKS = -0.350 + 0.806 * S
38730        AGS = -1.663
38731        BS  =  3.148
38732        DS  =  2.273 + 1.438 * S
38733        EST =  3.214 + 1.545 * S
38734        ESS =  1.341 + 1.938 * S
38735        QBP =  PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38736 C...X * CBAR = X * C :
38737        SC  =  0.820
38738        ALC =   0.98
38739        BEC =   0.0
38740        AKC =   0.0  - 0.457 * S
38741        AGC =   0.0
38742        BC  =  -1.00 +  1.40 * S
38743        DC  =  1.318 + 0.584 * S
38744        EC  =   4.45 + 1.235 * S
38745        ESC =  1.496 + 1.010 * S
38746        CBP =  PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38747 C...X * BBAR = X * B :
38748        SBO =  1.297
38749        ALB =   0.99
38750        BEB =   0.0
38751        AKB =   0.0  - 0.172 * S
38752        AGB =   0.0
38753        BBO =   0.0
38754        DB  =  1.447 + 0.485 * S
38755        EB  =   4.79 + 1.164 * S
38756        ESB =  1.724 + 2.121 * S
38757        BBP =  PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38758
38759       END
38760
38761 CDECK  ID>, PHO_DORFVP
38762       DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
38763       IMPLICIT DOUBLE PRECISION (A - Z)
38764       SAVE
38765
38766        DX = SQRT (X)
38767        PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
38768
38769       END
38770
38771 CDECK  ID>, PHO_DORFGP
38772       DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
38773      &                                    BG,C,D,E,ES)
38774       IMPLICIT DOUBLE PRECISION (A - Z)
38775       SAVE
38776
38777        DX = SQRT (X)
38778        LX = LOG (1./X)
38779        PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
38780      1       * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38781
38782       END
38783
38784 CDECK  ID>, PHO_DORFQP
38785       DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38786       IMPLICIT DOUBLE PRECISION (A - Z)
38787       SAVE
38788
38789        DX = SQRT (X)
38790        LX = LOG (1./X)
38791        IF (S .LE. ST) THEN
38792           PHO_DORFQP = 0.0
38793        ELSE
38794           PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38795      1           * EXP (-E + SQRT (ES * S**BE * LX))
38796        END IF
38797
38798       END
38799
38800 CDECK  ID>, PHO_DORGLO
38801 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38802 *                                                                 *
38803 *      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      *
38804 *                                                                 *
38805 *                 FOR A DETAILED EXPLANATION SEE :                *
38806 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31             *
38807 *                                                                 *
38808 *    THE OUTPUT IS ALWAYS   1./ ALPHA(EM) * X * PARTON DENSITY    *
38809 *                                                                 *
38810 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38811 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38812 *   / HO) AND  1.E6 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38813 *                                                                 *
38814 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38815 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38816 *                                                                 *
38817 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38818 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38819 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38820 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38821 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38822 *                                                                 *
38823 *      HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE :     *
38824 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26             *
38825 *                                                                 *
38826 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38827 C
38828       SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
38829       IMPLICIT DOUBLE PRECISION (A - Z)
38830       SAVE
38831
38832        MU2  = 0.25
38833        LAM2 = 0.232 * 0.232
38834        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38835        SS = SQRT (S)
38836        S2 = S * S
38837 C...X * U = X * UBAR :
38838        AL =  1.717
38839        BE =  0.641
38840        AK =  0.500 - 0.176 * S
38841        BK = 15.00  - 5.687 * SS - 0.552 * S2
38842        AG =  0.235 + 0.046 * SS
38843        BG =  0.082 - 0.051 * S  + 0.168 * S2
38844        C  =   0.0  + 0.459 * S
38845        D  =  0.354 - 0.061 * S
38846        E  =  4.899 + 1.678 * S
38847        ES =  2.046 + 1.389 * S
38848        UL =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38849 C...X * D = X * DBAR :
38850        AL =  1.549
38851        BE =  0.782
38852        AK =  0.496 + 0.026 * S
38853        BK =  0.685 - 0.580 * SS + 0.608 * S2
38854        AG =  0.233 + 0.302 * S
38855        BG =   0.0  - 0.818 * S  + 0.198 * S2
38856        C  =  0.114 + 0.154 * S
38857        D  =  0.405 - 0.195 * S  + 0.046 * S2
38858        E  =  4.807 + 1.226 * S
38859        ES =  2.166 + 0.664 * S
38860        DL  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38861 C...X * G :
38862        AL =  0.676
38863        BE =  1.089
38864        AK =  0.462 - 0.524 * SS
38865        BK =  5.451              - 0.804 * S2
38866        AG =  0.535 - 0.504 * SS + 0.288 * S2
38867        BG =  0.364 - 0.520 * S
38868        C  = -0.323              + 0.115 * S2
38869        D  =  0.233 + 0.790 * S  - 0.139 * S2
38870        E  =  0.893 + 1.968 * S
38871        ES =  3.432 + 0.392 * S
38872        GL =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38873 C...X * S = X * SBAR :
38874        SF =   0.0
38875        AL =  1.609
38876        BE =  0.962
38877        AK =  0.470              - 0.099 * S2
38878        BK =  3.246
38879        AG =  0.121 - 0.068 * SS
38880        BG = -0.090 + 0.074 * S
38881        C  =  0.062 + 0.034 * S
38882        D  =   0.0  + 0.226 * S  - 0.060 * S2
38883        E  =  4.288 + 1.707 * S
38884        ES =  2.122 + 0.656 * S
38885        SL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38886 C...X * C = X * CBAR :
38887        SF =  0.888
38888        AL =  0.970
38889        BE =  0.545
38890        AK =  1.254 - 0.251 * S
38891        BK =  3.932              - 0.327 * S2
38892        AG =  0.658 + 0.202 * S
38893        BG = -0.699
38894        C  =  0.965
38895        D  =   0.0  + 0.141 * S  - 0.027 * S2
38896        E  =  4.911 + 0.969 * S
38897        ES =  2.796 + 0.952 * S
38898        CL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38899 C...X * B = X * BBAR :
38900        SF =  1.351
38901        AL =  1.016
38902        BE =  0.338
38903        AK =  1.961 - 0.370 * S
38904        BK =  0.923 + 0.119 * S
38905        AG =  0.815 + 0.207 * S
38906        BG = -2.275
38907        C  =  1.480
38908        D  = -0.223 + 0.173 * S
38909        E  =  5.426 + 0.623 * S
38910        ES =  3.819 + 0.901 * S
38911        BL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38912
38913        END
38914
38915 CDECK  ID>, PHO_DORGHO
38916       SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
38917       IMPLICIT DOUBLE PRECISION (A - Z)
38918       SAVE
38919
38920        MU2  = 0.3
38921        LAM2 = 0.248 * 0.248
38922        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38923        SS = SQRT (S)
38924        S2 = S * S
38925 C...X * U = X * UBAR :
38926        AL =  0.583
38927        BE =  0.688
38928        AK =  0.449 - 0.025 * S  - 0.071 * S2
38929        BK =  5.060 - 1.116 * SS
38930        AG =  0.103
38931        BG =  0.319 + 0.422 * S
38932        C  =  1.508 + 4.792 * S  - 1.963 * S2
38933        D  =  1.075 + 0.222 * SS - 0.193 * S2
38934        E  =  4.147 + 1.131 * S
38935        ES =  1.661 + 0.874 * S
38936        UH =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38937 C...X * D = X * DBAR :
38938        AL =  0.591
38939        BE =  0.698
38940        AK =  0.442 - 0.132 * S  - 0.058 * S2
38941        BK =  5.437 - 1.916 * SS
38942        AG =  0.099
38943        BG =  0.311 - 0.059 * S
38944        C  =  0.800 + 0.078 * S  - 0.100 * S2
38945        D  =  0.862 + 0.294 * SS - 0.184 * S2
38946        E  =  4.202 + 1.352 * S
38947        ES =  1.841 + 0.990 * S
38948        DH  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38949 C...X * G :
38950        AL =  1.161
38951        BE =  1.591
38952        AK =  0.530 - 0.742 * SS + 0.025 * S2
38953        BK =  5.662
38954        AG =  0.533 - 0.281 * SS + 0.218 * S2
38955        BG =  0.025 - 0.518 * S  + 0.156 * S2
38956        C  = -0.282              + 0.209 * S2
38957        D  =  0.107 + 1.058 * S  - 0.218 * S2
38958        E  =   0.0  + 2.704 * S
38959        ES =  3.071 - 0.378 * S
38960        GH =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38961 C...X * S = X * SBAR :
38962        SF =   0.0
38963        AL =  0.635
38964        BE =  0.456
38965        AK =  1.770 - 0.735 * SS - 0.079 * S2
38966        BK =  3.832
38967        AG =  0.084 - 0.023 * S
38968        BG =  0.136
38969        C  =  2.119 - 0.942 * S  + 0.063 * S2
38970        D  =  1.271 + 0.076 * S  - 0.190 * S2
38971        E  =  4.604 + 0.737 * S
38972        ES =  1.641 + 0.976 * S
38973        SH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38974 C...X * C = X * CBAR :
38975        SF =  0.820
38976        AL =  0.926
38977        BE =  0.152
38978        AK =  1.142 - 0.175 * S
38979        BK =  3.276
38980        AG =  0.504 + 0.317 * S
38981        BG = -0.433
38982        C  =  3.334
38983        D  =  0.398 + 0.326 * S  - 0.107 * S2
38984        E  =  5.493 + 0.408 * S
38985        ES =  2.426 + 1.277 * S
38986        CH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38987 C...X * B = X * BBAR :
38988        SF =  1.297
38989        AL =  0.969
38990        BE =  0.266
38991        AK =  1.953 - 0.391 * S
38992        BK =  1.657 - 0.161 * S
38993        AG =  1.076 + 0.034 * S
38994        BG = -2.015
38995        C  =  1.662
38996        D  =  0.353 + 0.016 * S
38997        E  =  5.713 + 0.249 * S
38998        ES =  3.456 + 0.673 * S
38999        BH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39000
39001       END
39002
39003 CDECK  ID>, PHO_DORGH0
39004       SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
39005       IMPLICIT DOUBLE PRECISION (A - Z)
39006       SAVE
39007
39008        MU2  = 0.3
39009        LAM2 = 0.248 * 0.248
39010        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39011        SS = SQRT (S)
39012        S2 = S * S
39013 C...X * U = X * UBAR :
39014        AL =  1.447
39015        BE =  0.848
39016        AK =  0.527 + 0.200 * S  - 0.107 * S2
39017        BK =  7.106 - 0.310 * SS - 0.786 * S2
39018        AG =  0.197 + 0.533 * S
39019        BG =  0.062 - 0.398 * S  + 0.109 * S2
39020        C  =          0.755 * S  - 0.112 * S2
39021        D  =  0.318 - 0.059 * S
39022        E  =  4.225 + 1.708 * S
39023        ES =  1.752 + 0.866 * S
39024        U0 =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39025 C...X * D = X * DBAR :
39026        AL =  1.424
39027        BE =  0.770
39028        AK =  0.500 + 0.067 * SS - 0.055 * S2
39029        BK =  0.376 - 0.453 * SS + 0.405 * S2
39030        AG =  0.156 + 0.184 * S
39031        BG =   0.0  - 0.528 * S  + 0.146 * S2
39032        C  =  0.121 + 0.092 * S
39033        D  =  0.379 - 0.301 * S  + 0.081 * S2
39034        E  =  4.346 + 1.638 * S
39035        ES =  1.645 + 1.016 * S
39036        D0  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39037 C...X * G :
39038        AL =  0.661
39039        BE =  0.793
39040        AK =  0.537 - 0.600 * SS
39041        BK =  6.389              - 0.953 * S2
39042        AG =  0.558 - 0.383 * SS + 0.261 * S2
39043        BG =   0.0  - 0.305 * S
39044        C  = -0.222              + 0.078 * S2
39045        D  =  0.153 + 0.978 * S  - 0.209 * S2
39046        E  =  1.429 + 1.772 * S
39047        ES =  3.331 + 0.806 * S
39048        G0 =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39049 C...X * S = X * SBAR :
39050        SF =   0.0
39051        AL =  1.578
39052        BE =  0.863
39053        AK =  0.622 + 0.332 * S  - 0.300 * S2
39054        BK =  2.469
39055        AG =  0.211 - 0.064 * SS - 0.018 * S2
39056        BG = -0.215 + 0.122 * S
39057        C  =  0.153
39058        D  =   0.0  + 0.253 * S  - 0.081 * S2
39059        E  =  3.990 + 2.014 * S
39060        ES =  1.720 + 0.986 * S
39061        S0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39062 C...X * C = X * CBAR :
39063        SF =  0.820
39064        AL =  0.929
39065        BE =  0.381
39066        AK =  1.228 - 0.231 * S
39067        BK =  3.806             - 0.337 * S2
39068        AG =  0.932 + 0.150 * S
39069        BG = -0.906
39070        C  =  1.133
39071        D  =   0.0  + 0.138 * S  - 0.028 * S2
39072        E  =  5.588 + 0.628 * S
39073        ES =  2.665 + 1.054 * S
39074        C0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39075 C...X * B = X * BBAR :
39076        SF =  1.297
39077        AL =  0.970
39078        BE =  0.207
39079        AK =  1.719 - 0.292 * S
39080        BK =  0.928 + 0.096 * S
39081        AG =  0.845 + 0.178 * S
39082        BG = -2.310
39083        C  =  1.558
39084        D  = -0.191 + 0.151 * S
39085        E  =  6.089 + 0.282 * S
39086        ES =  3.379 + 1.062 * S
39087        B0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39088
39089       END
39090
39091 CDECK  ID>, PHO_DORGF
39092       DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39093      &                                   AG,BG,C,D,E,ES)
39094       IMPLICIT DOUBLE PRECISION (A - Z)
39095       SAVE
39096
39097        SX = SQRT (X)
39098        LX = LOG (1./X)
39099        PHO_DORGF  = (X**AK * (AG + BG * SX + C * X**BK)  +  S**AL
39100      1       * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39101
39102       END
39103
39104 CDECK  ID>, PHO_DORGFS
39105       DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39106      &                                     C,D,E,ES)
39107       IMPLICIT DOUBLE PRECISION (A - Z)
39108       SAVE
39109
39110        IF (S .LE. SF) THEN
39111           PHO_DORGFS = 0.0
39112        ELSE
39113           SX = SQRT (X)
39114           LX = LOG (1./X)
39115           DS = S - SF
39116           PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39117      1         * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39118        END IF
39119
39120       END
39121
39122 CDECK  ID>, PHO_DORGLV
39123 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39124 *                                                                 *
39125 *           G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS          *
39126 *                                                                 *
39127 *                 FOR A DETAILED EXPLANATION SEE                  *
39128 *                M. GLUECK, E.REYA, M. STRATMANN :                *
39129 *                    PHYS. REV. D51 (1995) 3220                   *
39130 *                                                                 *
39131 *   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
39132 *        Q**2 / GEV**2  BETWEEN   0.6   AND  5.E4                 *
39133 *                       AND (!)  Q**2 > 5 P**2                    *
39134 *        P**2 / GEV**2  BETWEEN   0.0   AND  10.                  *
39135 *                       P**2 = 0  <=> REAL PHOTON                 *
39136 *             X         BETWEEN  1.E-4  AND   1.                  *
39137 *                                                                 *
39138 *   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
39139 *                   M(C)  =  1.5,  M(B)  =  4.5                   *
39140 *   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
39141 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
39142 *             LAMBDA(5)  =  0.153,                                *
39143 *   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
39144 *   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
39145 *   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
39146 *                                                                 *
39147 *   PLEASE REPORT ANY STRANGE BEHAVIOUR TO :                      *
39148 *                  Marco.Stratmann@durham.ac.uk                   *
39149 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39150 *
39151 *...INPUT PARAMETERS :
39152 *
39153 *    X   = MOMENTUM FRACTION
39154 *    Q2  = SCALE Q**2 IN GEV**2
39155 *    P2  = VIRTUALITY OF THE PHOTON IN GEV**2
39156 *
39157 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39158 *
39159 ********************************************************
39160 *     subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39161       subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39162       implicit double precision (a-z)
39163       save
39164
39165 C  input/output channels
39166       INTEGER LI,LO
39167       COMMON /POINOU/ LI,LO
39168
39169       integer check
39170 c
39171 c     check limits :
39172 c
39173       check=0
39174       if(x.lt.0.0001d0) check=1
39175       if((q2.lt.0.6d0).or.(q2.gt.50000.d0))  check=1
39176       if(q2.lt.5.d0*p2) check=1
39177 c
39178 c     calculate distributions
39179 c
39180       if(check.eq.0) then
39181          call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39182       else
39183          WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39184          WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39185       endif
39186
39187       end
39188
39189 CDECK  ID>, PHO_grscalc
39190       subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39191       implicit double precision (a-z)
39192       save
39193
39194       dimension u1(40),ds1(40),g1(40)
39195       dimension ud2(20),s2(20),g2(20)
39196       dimension up0(20),dsp0(20),gp0(20)
39197       save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
39198 c
39199       data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39200      &   0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39201      &   0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39202      &   0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39203      &   0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39204      &   -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39205      &   0.622d0,0.227d0,-0.184d0/
39206       data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39207      &   0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39208      &   0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39209      &   0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39210      &   0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39211      &   0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39212      &   0.245d0,-0.171d0/
39213       data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39214      &   -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39215      &   -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39216      &   0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39217      &   0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39218      &   0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39219       data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39220      &   0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39221      &   -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39222      &   -0.614d0,3.548d0/
39223       data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39224      &   -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39225      &   -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39226      &   -0.48d0,3.401d0/
39227       data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39228      &   -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39229      &   0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39230      &   -0.079d0/
39231       data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39232      &   0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39233      &   0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39234      &   2.294d0/
39235       data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39236      &   -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39237      &   0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39238      &   0.814d0,1.531d0,0.124d0/
39239       data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39240      &   -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39241      &   -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39242      &   2.264d0,0.2675d0/
39243 c
39244       mu2=0.25d0
39245       lam2=0.232d0*0.232d0
39246 c
39247       if(p2.le.0.25d0) then
39248          s=log(log(q2/lam2)/log(mu2/lam2))
39249          lp1=0.d0
39250          lp2=0.d0
39251       else
39252          s=log(log(q2/lam2)/log(p2/lam2))
39253          lp1=log(p2/mu2)*log(p2/mu2)
39254          lp2=log(p2/mu2+log(p2/mu2))
39255       endif
39256 c
39257       alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39258       bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39259       a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39260      &  (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39261       b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39262      &  (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39263      &  (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39264       gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39265      &  (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39266      &  (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39267       ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39268      &  (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39269       gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39270      &  (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39271       gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39272      &  (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39273       ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39274      &  (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39275       gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39276      &  (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39277       upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39278 c
39279       alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39280       bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39281       a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39282      &  (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39283       b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39284      &  (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39285      &  (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39286       gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39287      &  (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39288      &  (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39289       ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39290      &  (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39291       gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39292      &  (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39293       gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39294      &  (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39295       ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39296      &  (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39297       gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39298      &  (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39299       dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39300 c
39301       alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39302       bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39303       a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39304      &  (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39305       b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39306      &  (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39307       gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39308      &  (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39309       ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39310      &  (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39311      &  (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39312       gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39313      &  (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39314       gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39315      &  (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39316      &  (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39317       ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39318      &  (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39319       gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39320      &  (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39321       gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39322 c
39323       s=log(log(q2/lam2)/log(mu2/lam2))
39324       suppr=1.d0/(1.d0+p2/0.59d0)**2
39325 c
39326       alp=ud2(1)
39327       bet=ud2(2)
39328       a=ud2(3)+ud2(4)*s
39329       ga=ud2(5)+ud2(6)*s**0.5
39330       gc=ud2(7)+ud2(8)*s
39331       b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39332       gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39333       gd=ud2(15)+ud2(16)*s
39334       ge=ud2(17)+ud2(18)*s
39335       gep=ud2(19)+ud2(20)*s
39336       udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39337 c
39338       alp=s2(1)
39339       bet=s2(2)
39340       a=s2(3)+s2(4)*s
39341       ga=s2(5)+s2(6)*s**0.5
39342       gc=s2(7)+s2(8)*s
39343       b=s2(9)+s2(10)*s+s2(11)*s**2
39344       gb=s2(12)+s2(13)*s+s2(14)*s**2
39345       gd=s2(15)+s2(16)*s
39346       ge=s2(17)+s2(18)*s
39347       gep=s2(19)+s2(20)*s
39348       spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39349 c
39350       alp=g2(1)
39351       bet=g2(2)
39352       a=g2(3)+g2(4)*s**0.5
39353       b=g2(5)+g2(6)*s**2
39354       gb=g2(7)+g2(8)*s
39355       ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39356       gc=g2(12)+g2(13)*s**2
39357       gd=g2(14)+g2(15)*s+g2(16)*s**2
39358       ge=g2(17)+g2(18)*s
39359       gep=g2(19)+g2(20)*s
39360       gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39361 c
39362       ugam=upart1+udpart2
39363       dgam=dspart1+udpart2
39364       sgam=dspart1+spart2
39365       ggam=gpart1+gpart2
39366 c
39367       end
39368
39369 CDECK  ID>, PHO_grsf1
39370       DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39371      &                                ge,gep)
39372       implicit double precision (a-z)
39373       save
39374
39375       PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39376      &      s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39377      &      (1.d0-x)**gd
39378
39379       end
39380
39381 CDECK  ID>, PHO_grsf2
39382       DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39383      &                                ge,gep)
39384       implicit double precision (a-z)
39385       save
39386
39387       PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39388      &      s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39389      &      (1.d0-x)**gd
39390
39391       end
39392
39393 CDECK  ID>, PHO_CKMTPA
39394       SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39395 C**********************************************************************
39396 C
39397 C     PDF based on Regge theory, evolved with .... by ....
39398 C
39399 C     input: IPAR     2212   proton (not installed)
39400 C                      990   Pomeron
39401 C
39402 C     output: parameters of parametrization
39403 C
39404 C**********************************************************************
39405       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39406       SAVE
39407
39408       CHARACTER*8 PDFNA
39409
39410 C  input/output channels
39411       INTEGER LI,LO
39412       COMMON /POINOU/ LI,LO
39413
39414       REAL PROP(40),POMP(40)
39415       DATA PROP /
39416      & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39417      & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39418      & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39419      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39420      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39421      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39422      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39423      & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39424       DATA POMP /
39425      & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39426      & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39427      & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
39428      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39429      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39430      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39431      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39432      & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39433
39434       IF(IPA.EQ.2212) THEN
39435         ALA  =PROP(1)
39436         Q2MI = PROP(39)
39437         Q2MA = PROP(40)
39438         PDFNA = 'CKMT-PRO'
39439       ELSE IF(IPA.EQ.990) THEN
39440         ALA  = POMP(1)
39441         Q2MI = POMP(39)
39442         Q2MA = POMP(40)
39443         PDFNA = 'CKMT-POM'
39444       ELSE
39445         WRITE(LO,'(1X,A,I7)')
39446      &    'PHO_CKMTPA:ERROR: invalid particle code',IPA
39447         STOP
39448       ENDIF
39449       XMI = 1.D-4
39450       XMA = 1.D0
39451       END
39452
39453 CDECK  ID>, PHO_CKMTPD
39454       SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39455 C**********************************************************************
39456 C
39457 C     PDF based on Regge theory, evolved with .... by ....
39458 C
39459 C     input: IPAR     2212   proton (not installed)
39460 C                      990   Pomeron
39461 C
39462 C     output: PD(-6:6) x*f(x)  parton distribution functions
39463 C            (PDFLIB convention: d = PD(1), u = PD(2) )
39464 C
39465 C**********************************************************************
39466       SAVE
39467
39468 C  input/output channels
39469       INTEGER LI,LO
39470       COMMON /POINOU/ LI,LO
39471
39472       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP
39473       DIMENSION QQ(7)
39474
39475       Q2=SNGL(SCALE2)
39476       Q1S=Q2
39477       XX=SNGL(X)
39478 C  QCD lambda for evolution
39479       OWLAM = 0.23D0
39480       OWLAM2=OWLAM**2
39481 C  Q0**2 for evolution
39482       Q02 = 2.D0
39483 C
39484 C
39485 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39486 C                        q(6)=x*charm, q(7)=x*gluon
39487 C
39488       SB=0.
39489       IF(Q2-Q02) 1,1,2
39490     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39491     1 CONTINUE
39492       IF(IPAR.EQ.2212) THEN
39493 *       CALL PHO_CKMTPR(XX,SB,QQ
39494         WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39495         CALL PHO_ABORT
39496       ELSE
39497         CALL PHO_CKMTPO(XX,SB,QQ)
39498       ENDIF
39499 C
39500       PD(-6) = 0.D0
39501       PD(-5) = 0.D0
39502       PD(-4) = DBLE(QQ(6))
39503       PD(-3) = DBLE(QQ(3))
39504       PD(-2) = DBLE(QQ(4))
39505       PD(-1) = DBLE(QQ(5))
39506       PD(0)  = DBLE(QQ(7))
39507       PD(1)  = DBLE(QQ(2))
39508       PD(2)  = DBLE(QQ(1))
39509       PD(3)  = DBLE(QQ(3))
39510       PD(4)  = DBLE(QQ(6))
39511       PD(5)  = 0.D0
39512       PD(6)  = 0.D0
39513       IF(IPAR.EQ.990) THEN
39514         CDN = (PD(1)-PD(-1))/2.D0
39515         CUP = (PD(2)-PD(-2))/2.D0
39516         PD(-1) = PD(-1) + CDN
39517         PD(-2) = PD(-2) + CUP
39518         PD(1) = PD(-1)
39519         PD(2) = PD(-2)
39520       ENDIF
39521       END
39522
39523 CDECK  ID>, PHO_CKMTPO
39524       SUBROUTINE PHO_CKMTPO(X,S,QQ)
39525 C**********************************************************************
39526 C
39527 C    calculation partons in Pomeron
39528 C
39529 C**********************************************************************
39530       SAVE
39531
39532       DIMENSION QQ(7)
39533
39534 C  input/output channels
39535       INTEGER LI,LO
39536       COMMON /POINOU/ LI,LO
39537
39538       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39539       EQUIVALENCE (GF(1,1,1),DL(1))
39540       DATA DELTA/.10/
39541
39542 C  RNG=  -.5
39543 C  DEU.NORM. QUARKS,GLUONS,NEW NORM   .6223E+00   .2754E+00   .1372E+01
39544 C  POM.NORM. QUARKS,GLUONS,ALL    .132E+00    .275E+00    .407E+00
39545       DATA (DL(K),K=    1,   85) /
39546      & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39547      & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39548      & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39549      & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39550      & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39551      & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39552      & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39553      & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39554      & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39555      & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39556      & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39557      & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39558      & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39559      & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39560      & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39561      & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39562      & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39563       DATA (DL(K),K=   86,  170) /
39564      & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39565      & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39566      & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39567      & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39568      & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39569      & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39570      & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39571      & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39572      & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39573      & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39574      & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39575      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39576      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39577      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39578      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39579      & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39580      & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39581       DATA (DL(K),K=  171,  255) /
39582      & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39583      & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39584      & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39585      & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39586      & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39587      & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39588      & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39589      & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39590      & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39591      & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39592      & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39593      & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39594      & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39595      & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39596      & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39597      & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39598      & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39599       DATA (DL(K),K=  256,  340) /
39600      & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39601      & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39602      & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39603      & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39604      & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
39605      & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
39606      & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
39607      & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
39608      & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39609      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39610      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39611      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39612      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39613      & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
39614      & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
39615      & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
39616      & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
39617       DATA (DL(K),K=  341,  425) /
39618      & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
39619      & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
39620      & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
39621      & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
39622      & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
39623      & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
39624      & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
39625      & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
39626      & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
39627      & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
39628      & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
39629      & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
39630      & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
39631      & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
39632      & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
39633      & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
39634      & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
39635       DATA (DL(K),K=  426,  510) /
39636      & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
39637      & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
39638      & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
39639      & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
39640      & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
39641      & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
39642      & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39643      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39644      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39645      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39646      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39647      & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
39648      & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
39649      & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
39650      & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
39651      & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
39652      & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
39653       DATA (DL(K),K=  511,  595) /
39654      & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
39655      & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
39656      & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
39657      & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
39658      & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
39659      & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
39660      & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
39661      & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
39662      & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
39663      & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
39664      & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
39665      & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
39666      & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
39667      & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
39668      & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
39669      & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
39670      & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
39671       DATA (DL(K),K=  596,  680) /
39672      & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
39673      & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
39674      & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
39675      & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
39676      & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39677      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39678      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39679      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39680      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39681      & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
39682      & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
39683      & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
39684      & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
39685      & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
39686      & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
39687      & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
39688      & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
39689       DATA (DL(K),K=  681,  765) /
39690      & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
39691      & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
39692      & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
39693      & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
39694      & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
39695      & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
39696      & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
39697      & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
39698      & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
39699      & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
39700      & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
39701      & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
39702      & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
39703      & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
39704      & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
39705      & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
39706      & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
39707       DATA (DL(K),K=  766,  850) /
39708      & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
39709      & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
39710      & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39711      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39712      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39713      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39714      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39715      & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
39716      & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
39717      & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
39718      & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
39719      & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
39720      & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
39721      & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
39722      & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
39723      & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
39724      & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
39725       DATA (DL(K),K=  851,  935) /
39726      & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
39727      & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
39728      & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
39729      & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
39730      & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
39731      & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
39732      & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
39733      & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
39734      & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
39735      & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
39736      & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
39737      & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
39738      & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
39739      & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
39740      & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
39741      & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
39742      & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
39743       DATA (DL(K),K=  936, 1020) /
39744      & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39745      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39746      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39747      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39748      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39749      & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
39750      & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
39751      & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
39752      & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
39753      & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
39754      & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
39755      & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
39756      & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
39757      & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
39758      & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
39759      & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
39760      & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
39761       DATA (DL(K),K= 1021, 1105) /
39762      & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
39763      & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
39764      & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
39765      & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
39766      & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
39767      & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
39768      & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
39769      & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
39770      & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
39771      & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
39772      & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
39773      & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
39774      & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
39775      & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
39776      & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
39777      & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39778      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39779       DATA (DL(K),K= 1106, 1190) /
39780      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39781      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39782      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39783      & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
39784      & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
39785      & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
39786      & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
39787      & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
39788      & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
39789      & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
39790      & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
39791      & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
39792      & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
39793      & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
39794      & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
39795      & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
39796      & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
39797       DATA (DL(K),K= 1191, 1275) /
39798      & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
39799      & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
39800      & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
39801      & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
39802      & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
39803      & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
39804      & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
39805      & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
39806      & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
39807      & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
39808      & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
39809      & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
39810      & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
39811      & .258043E-01, .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, .000000E+00, .000000E+00, .000000E+00/
39815       DATA (DL(K),K= 1276, 1360) /
39816      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39817      & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
39818      & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
39819      & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
39820      & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
39821      & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
39822      & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
39823      & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
39824      & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
39825      & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
39826      & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
39827      & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
39828      & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
39829      & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
39830      & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
39831      & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
39832      & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
39833       DATA (DL(K),K= 1361, 1445) /
39834      & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
39835      & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
39836      & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
39837      & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
39838      & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
39839      & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
39840      & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
39841      & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
39842      & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
39843      & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
39844      & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
39845      & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39846      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39847      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39848      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39849      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39850      & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
39851       DATA (DL(K),K= 1446, 1530) /
39852      & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
39853      & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
39854      & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
39855      & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
39856      & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
39857      & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
39858      & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
39859      & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
39860      & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
39861      & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
39862      & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
39863      & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
39864      & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
39865      & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
39866      & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
39867      & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
39868      & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
39869       DATA (DL(K),K= 1531, 1615) /
39870      & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
39871      & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
39872      & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
39873      & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
39874      & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
39875      & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
39876      & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
39877      & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
39878      & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
39879      & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39880      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39881      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39882      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39883      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39884      & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
39885      & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
39886      & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
39887       DATA (DL(K),K= 1616, 1700) /
39888      & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
39889      & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
39890      & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
39891      & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
39892      & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
39893      & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
39894      & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
39895      & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
39896      & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
39897      & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
39898      & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
39899      & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
39900      & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
39901      & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
39902      & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
39903      & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
39904      & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
39905       DATA (DL(K),K= 1701, 1785) /
39906      & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
39907      & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
39908      & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
39909      & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
39910      & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
39911      & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
39912      & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
39913      & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39914      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39915      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39916      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39917      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39918      & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
39919      & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
39920      & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
39921      & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
39922      & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
39923       DATA (DL(K),K= 1786, 1870) /
39924      & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
39925      & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
39926      & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
39927      & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
39928      & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
39929      & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
39930      & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
39931      & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
39932      & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
39933      & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
39934      & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
39935      & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
39936      & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
39937      & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
39938      & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
39939      & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
39940      & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
39941       DATA (DL(K),K= 1871, 1955) /
39942      & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
39943      & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
39944      & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
39945      & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
39946      & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
39947      & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39948      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39949      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39950      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39951      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39952      & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
39953      & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
39954      & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
39955      & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
39956      & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
39957      & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
39958      & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
39959       DATA (DL(K),K= 1956, 2040) /
39960      & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
39961      & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
39962      & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
39963      & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
39964      & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
39965      & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
39966      & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
39967      & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
39968      & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
39969      & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
39970      & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
39971      & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
39972      & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
39973      & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
39974      & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
39975      & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
39976      & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
39977       DATA (DL(K),K= 2041, 2125) /
39978      & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
39979      & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
39980      & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
39981      & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39982      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39983      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39984      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39985      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39986      & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
39987      & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
39988      & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
39989      & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
39990      & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
39991      & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
39992      & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
39993      & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
39994      & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
39995       DATA (DL(K),K= 2126, 2210) /
39996      & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
39997      & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
39998      & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
39999      & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
40000      & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
40001      & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
40002      & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
40003      & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
40004      & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
40005      & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
40006      & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
40007      & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
40008      & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
40009      & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
40010      & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
40011      & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
40012      & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
40013       DATA (DL(K),K= 2211, 2295) /
40014      & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
40015      & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40016      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40017      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40018      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40019      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40020      & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
40021      & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
40022      & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
40023      & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
40024      & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
40025      & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
40026      & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
40027      & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
40028      & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
40029      & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
40030      & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
40031       DATA (DL(K),K= 2296, 2380) /
40032      & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
40033      & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
40034      & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
40035      & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
40036      & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
40037      & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
40038      & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
40039      & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
40040      & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
40041      & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
40042      & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
40043      & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
40044      & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
40045      & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
40046      & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
40047      & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
40048      & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40049       DATA (DL(K),K= 2381, 2465) /
40050      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40051      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40052      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40053      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40054      & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40055      & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40056      & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40057      & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40058      & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40059      & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40060      & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40061      & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40062      & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40063      & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40064      & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40065      & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40066      & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40067       DATA (DL(K),K= 2466, 2550) /
40068      & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40069      & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40070      & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40071      & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40072      & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40073      & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40074      & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40075      & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40076      & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40077      & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40078      & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40079      & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40080      & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40081      & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40082      & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40083      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40084      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40085       DATA (DL(K),K= 2551, 2635) /
40086      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40087      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40088      & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40089      & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40090      & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40091      & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40092      & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40093      & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40094      & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40095      & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40096      & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40097      & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40098      & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40099      & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40100      & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40101      & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40102      & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40103       DATA (DL(K),K= 2636, 2720) /
40104      & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40105      & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40106      & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40107      & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40108      & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40109      & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40110      & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40111      & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40112      & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40113      & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40114      & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40115      & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40116      & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40117      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40118      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40119      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40120      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40121       DATA (DL(K),K= 2721, 2805) /
40122      & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40123      & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40124      & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40125      & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40126      & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40127      & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40128      & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40129      & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40130      & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40131      & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40132      & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40133      & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40134      & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40135      & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40136      & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40137      & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40138      & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40139       DATA (DL(K),K= 2806, 2890) /
40140      & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40141      & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40142      & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40143      & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40144      & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40145      & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40146      & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40147      & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40148      & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40149      & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40150      & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40151      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40152      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40153      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40154      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40155      & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40156      & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40157       DATA (DL(K),K= 2891, 2975) /
40158      & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40159      & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40160      & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40161      & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40162      & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40163      & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40164      & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40165      & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40166      & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40167      & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40168      & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40169      & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40170      & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40171      & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40172      & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40173      & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40174      & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40175       DATA (DL(K),K= 2976, 3060) /
40176      & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40177      & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40178      & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40179      & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40180      & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40181      & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40182      & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40183      & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40184      & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40185      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40186      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40187      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40188      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40189      & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40190      & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40191      & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40192      & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40193       DATA (DL(K),K= 3061, 3145) /
40194      & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40195      & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40196      & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40197      & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40198      & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40199      & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40200      & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40201      & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40202      & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40203      & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40204      & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40205      & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40206      & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40207      & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40208      & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40209      & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40210      & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40211       DATA (DL(K),K= 3146, 3230) /
40212      & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40213      & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40214      & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40215      & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40216      & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40217      & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40218      & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40219      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40220      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40221      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40222      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40223      & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40224      & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40225      & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40226      & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40227      & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40228      & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40229       DATA (DL(K),K= 3231, 3315) /
40230      & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40231      & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40232      & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40233      & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40234      & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40235      & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40236      & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40237      & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40238      & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40239      & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40240      & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40241      & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40242      & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40243      & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40244      & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40245      & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40246      & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40247       DATA (DL(K),K= 3316, 3400) /
40248      & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40249      & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40250      & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40251      & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40252      & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40253      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40254      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40255      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40256      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40257      & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40258      & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40259      & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40260      & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40261      & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40262      & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40263      & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40264      & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40265       DATA (DL(K),K= 3401, 3485) /
40266      & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40267      & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40268      & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40269      & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40270      & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40271      & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40272      & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40273      & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40274      & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40275      & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40276      & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40277      & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40278      & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40279      & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40280      & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40281      & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40282      & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40283       DATA (DL(K),K= 3486, 3570) /
40284      & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40285      & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40286      & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40287      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40288      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40289      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40290      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40291      & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40292      & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40293      & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40294      & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40295      & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40296      & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40297      & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40298      & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40299      & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40300      & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40301       DATA (DL(K),K= 3571, 3655) /
40302      & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40303      & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40304      & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40305      & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40306      & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40307      & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40308      & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40309      & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40310      & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40311      & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40312      & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40313      & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40314      & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40315      & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40316      & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40317      & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40318      & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40319       DATA (DL(K),K= 3656, 3740) /
40320      & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40321      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40322      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40323      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40324      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40325      & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40326      & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40327      & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40328      & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40329      & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40330      & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40331      & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40332      & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40333      & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40334      & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40335      & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40336      & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40337       DATA (DL(K),K= 3741, 3825) /
40338      & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40339      & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40340      & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40341      & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40342      & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40343      & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40344      & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40345      & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40346      & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40347      & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40348      & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40349      & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40350      & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40351      & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40352      & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40353      & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40354      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40355       DATA (DL(K),K= 3826, 3910) /
40356      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40357      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40358      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40359      & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40360      & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40361      & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40362      & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40363      & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40364      & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40365      & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40366      & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40367      & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40368      & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40369      & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40370      & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40371      & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40372      & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40373       DATA (DL(K),K= 3911, 3995) /
40374      & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40375      & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40376      & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40377      & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40378      & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40379      & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40380      & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40381      & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40382      & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40383      & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40384      & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40385      & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40386      & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40387      & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40388      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40389      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40390      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40391       DATA (DL(K),K= 3996, 4000) /
40392      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40393
40394       DO 10 I=1,7
40395         QQ(I) = 0.
40396  10   CONTINUE
40397       IF(X.GT.0.9985) RETURN
40398
40399       IS = S/DELTA+1
40400       IS = MIN(IS,19)
40401       IS1 = IS+1
40402       DO 20 I=1,7
40403         IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40404         IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40405         DO 30 L=1,25
40406           F1(L)=GF(I,IS,L)
40407           F2(L)=GF(I,IS1,L)
40408  30     CONTINUE
40409         S1=(IS-1)*DELTA
40410         S2=S1+DELTA
40411         A1 = PHO_CKMTFV(X,F1)
40412         A2 = PHO_CKMTFV(X,F2)
40413         QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40414  19     CONTINUE
40415  20   CONTINUE
40416
40417       END
40418
40419 CDECK  ID>, PHO_CKMTFV
40420       REAL FUNCTION PHO_CKMTFV(X,FVL)
40421 C**********************************************************************
40422 C
40423 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40424 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40425 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40426 C     IN MAIN ROUTINE.
40427 C
40428 C**********************************************************************
40429       SAVE
40430
40431       DIMENSION FVL(25),XGRID(25)
40432
40433 C  input/output channels
40434       INTEGER LI,LO
40435       COMMON /POINOU/ LI,LO
40436
40437       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40438      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40439
40440       PHO_CKMTFV=0.
40441       DO 1 I=1,NX
40442       IF(X.LT.XGRID(I)) GO TO 2
40443     1 CONTINUE
40444     2 I=I-1
40445       IF(I.EQ.0) THEN
40446          I=I+1
40447       ELSE IF(I.GT.23) THEN
40448          I=23
40449       ENDIF
40450       J=I+1
40451       K=J+1
40452       AXI=LOG(XGRID(I))
40453       BXI=LOG(1.-XGRID(I))
40454       AXJ=LOG(XGRID(J))
40455       BXJ=LOG(1.-XGRID(J))
40456       AXK=LOG(XGRID(K))
40457       BXK=LOG(1.-XGRID(K))
40458       FI=LOG(ABS(FVL(I)) +1.E-15)
40459       FJ=LOG(ABS(FVL(J)) +1.E-16)
40460       FK=LOG(ABS(FVL(K)) +1.E-17)
40461       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40462       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40463      $ BXI))/DET
40464       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40465       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40466       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40467      1RETURN
40468 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40469 C         WRITE(LO,2001) X,FVL
40470 C 2001    FORMAT(8E12.4)
40471 C         WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40472 C      ENDIF
40473       PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40474
40475       END
40476
40477 CDECK  ID>, PHO_SASGAM
40478 C***********************************************************************
40479 C...SaSgam version 2 - parton distributions of the photon
40480 C...by Gerhard A. Schuler and Torbjorn Sjostrand
40481 C...For further information see Z. Phys. C68 (1995) 607
40482 C...and Phys. Lett. B376 (1996) 193.
40483
40484 C...18 January 1996: original code.
40485 C...22 July 1996: calculation of BETA moved in SASBEH.
40486
40487 C!!!Note that one further call parameter - IP2 - has been added
40488 C!!!to the SASGAM argument list compared with version 1.
40489
40490 C...The user should only need to call the SASGAM routine,
40491 C...which in turn calls the auxiliary routines SASVMD, SASANO,
40492 C...SASBEH and SASDIR. The package is self-contained.
40493
40494 C...One particular aspect of these parametrizations is that F2 for
40495 C...the photon is not obtained just as the charge-squared-weighted
40496 C...sum of quark distributions, but differ in the treatment of
40497 C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40498 C...the kinematics range of heavy-flavour production, but the same
40499 C...kinematics is not relevant e.g. for jet production) and, for the
40500 C...'MSbar' fits, in the addition of a Cgamma term related to the
40501 C...separation of direct processes. Schematically:
40502 C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40503 C...F2  = VMD (rho, omega, phi) + anomalous (d, u, s) +
40504 C...      Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40505 C...The J/psi and Upsilon states have not been included in the VMD sum,
40506 C...but low c and b masses in the other components should compensate
40507 C...for this in a duality sense.
40508
40509 C...The calling sequence is the following:
40510 C     CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40511 C...with the following declaration statement:
40512 C     DIMENSION XPDFGM(-6:6)
40513 C...and, optionally, further information in:
40514 C     COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40515 C    &XPDIR(-6:6)
40516 C     COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40517 C...Input:  ISET = 1 : SaS set 1D ('DIS',   Q0 = 0.6 GeV)
40518 C                = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40519 C                = 3 : SaS set 2D ('DIS',   Q0 =  2  GeV)
40520 C                = 4 : SaS set 2M ('MSbar', Q0 =  2  GeV)
40521 C           X : x value.
40522 C           Q2 : Q2 value.
40523 C           P2 : P2 value; should be = 0. for an on-shell photon.
40524 C           IP2 : scheme used to evaluate off-shell anomalous component.
40525 C               = 0 : recommended default, see = 7.
40526 C               = 1 : dipole dampening by integration; very time-consuming.
40527 C               = 2 : P_0^2 = max( Q_0^2, P^2 )
40528 C               = 3 : P_0^2 = Q_0^2 + P^2.
40529 C               = 4 : P_{eff} that preserves momentum sum.
40530 C               = 5 : P_{int} that preserves momentum and average
40531 C                     evolution range.
40532 C               = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40533 C               = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40534 C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40535 C           XPFDGM :  x times parton distribution functions of the photon,
40536 C               with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40537 C               6 = t (always empty!), - for antiquarks (result is same).
40538 C...The breakdown by component is stored in the commonblock SASCOM,
40539 C               with elements as above.
40540 C           XPVMD : rho, omega, phi VMD part only of output.
40541 C           XPANL : d, u, s anomalous part only of output.
40542 C           XPANH : c, b anomalous part only of output.
40543 C           XPBEH : c, b Bethe-Heitler part only of output.
40544 C           XPDIR : Cgamma (direct contribution) part only of output.
40545 C...The above arrays do not distinguish valence and sea contributions,
40546 C...although this information is available internally. The additional
40547 C...commonblock SASVAL provides the valence part only of the above
40548 C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40549 C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40550 C...and therefore not given doubly. VXPDGM gives the sum of valence
40551 C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40552 C...and so on, gives the sea part only.
40553 C***********************************************************************
40554
40555       SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40556 C...Purpose: to construct the F2 and parton distributions of the photon
40557 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40558 C...For F2, c and b are included by the Bethe-Heitler formula;
40559 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40560       SAVE
40561       DIMENSION XPDFGM(-6:6)
40562
40563 C  input/output channels
40564       INTEGER LI,LO
40565       COMMON /POINOU/ LI,LO
40566
40567       COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40568      &XPDIR(-6:6)
40569       COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40570       SAVE /SASCOM/,/SASVAL/
40571
40572 C...Temporary array.
40573       DIMENSION XPGA(-6:6), VXPGA(-6:6)
40574 C...Charm and bottom masses (low to compensate for J/psi etc.).
40575       DATA PMC/1.3/, PMB/4.6/
40576 C...alpha_em and alpha_em/(2*pi).
40577       DATA AEM/0.007297/, AEM2PI/0.0011614/
40578 C...Lambda value for 4 flavours.
40579       DATA ALAM/0.20/
40580 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40581       DATA FRACU/0.8/
40582 C...VMD couplings f_V**2/(4*pi).
40583       DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40584 C...Masses for rho (=omega) and phi.
40585       DATA PMRHO/0.770/, PMPHI/1.020/
40586 C...Number of points in integration for IP2=1.
40587       DATA NSTEP/100/
40588
40589 C...Reset output.
40590       F2GM=0.
40591       DO 100 KFL=-6,6
40592       XPDFGM(KFL)=0.
40593       XPVMD(KFL)=0.
40594       XPANL(KFL)=0.
40595       XPANH(KFL)=0.
40596       XPBEH(KFL)=0.
40597       XPDIR(KFL)=0.
40598       VXPVMD(KFL)=0.
40599       VXPANL(KFL)=0.
40600       VXPANH(KFL)=0.
40601       VXPDGM(KFL)=0.
40602   100 CONTINUE
40603
40604 C...Check that input sensible.
40605       IF(ISET.LE.0.OR.ISET.GE.5) THEN
40606         WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
40607         WRITE(LO,*) ' ISET = ',ISET
40608         STOP
40609       ENDIF
40610       IF(X.LE.0..OR.X.GT.1.) THEN
40611         WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
40612         WRITE(LO,*) ' X = ',X
40613         STOP
40614       ENDIF
40615
40616 C...Set Q0 cut-off parameter as function of set used.
40617       IF(ISET.LE.2) THEN
40618         Q0=0.6
40619       ELSE
40620         Q0=2.
40621       ENDIF
40622       Q02=Q0**2
40623
40624 C...Scale choice for off-shell photon; common factors.
40625       Q2A=Q2
40626       FACNOR=1.
40627       IF(IP2.EQ.1) THEN
40628         P2MX=P2+Q02
40629         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40630         FACNOR=LOG(Q2/Q02)/NSTEP
40631       ELSEIF(IP2.EQ.2) THEN
40632         P2MX=MAX(P2,Q02)
40633       ELSEIF(IP2.EQ.3) THEN
40634         P2MX=P2+Q02
40635         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40636       ELSEIF(IP2.EQ.4) THEN
40637         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40638      &  ((Q2+P2)*(Q02+P2)))
40639       ELSEIF(IP2.EQ.5) THEN
40640         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40641      &  ((Q2+P2)*(Q02+P2)))
40642         P2MX=Q0*SQRT(P2MXA)
40643         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40644       ELSEIF(IP2.EQ.6) THEN
40645         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40646      &  ((Q2+P2)*(Q02+P2)))
40647         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40648       ELSE
40649         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40650      &  ((Q2+P2)*(Q02+P2)))
40651         P2MX=Q0*SQRT(P2MXA)
40652         P2MXB=P2MX
40653         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40654         P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
40655         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40656       ENDIF
40657
40658 C...Call VMD parametrization for d quark and use to give rho, omega,
40659 C...phi. Note dipole dampening for off-shell photon.
40660       CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40661       XFVAL=VXPGA(1)
40662       XPGA(1)=XPGA(2)
40663       XPGA(-1)=XPGA(-2)
40664       FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40665       FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40666       DO 110 KFL=-5,5
40667       XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40668   110 CONTINUE
40669       XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
40670       XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40671       XPVMD(3)=XPVMD(3)+FACS*XFVAL
40672       XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
40673       XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40674       XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40675       VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
40676       VXPVMD(2)=FRACU*FACUD*XFVAL
40677       VXPVMD(3)=FACS*XFVAL
40678       VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
40679       VXPVMD(-2)=FRACU*FACUD*XFVAL
40680       VXPVMD(-3)=FACS*XFVAL
40681
40682       IF(IP2.NE.1) THEN
40683 C...Anomalous parametrizations for different strategies
40684 C...for off-shell photons; except full integration.
40685
40686 C...Call anomalous parametrization for d + u + s.
40687         CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40688         DO 120 KFL=-5,5
40689         XPANL(KFL)=FACNOR*XPGA(KFL)
40690         VXPANL(KFL)=FACNOR*VXPGA(KFL)
40691   120   CONTINUE
40692
40693 C...Call anomalous parametrization for c and b.
40694         CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40695         DO 130 KFL=-5,5
40696         XPANH(KFL)=FACNOR*XPGA(KFL)
40697         VXPANH(KFL)=FACNOR*VXPGA(KFL)
40698   130   CONTINUE
40699         CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40700         DO 140 KFL=-5,5
40701         XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40702         VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40703   140   CONTINUE
40704
40705       ELSE
40706 C...Special option: loop over flavours and integrate over k2.
40707         DO 170 KF=1,5
40708         DO 160 ISTEP=1,NSTEP
40709         Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
40710         IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40711      &  (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40712         CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40713         FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40714         IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
40715         IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
40716         DO 150 KFL=-5,5
40717         IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40718         IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40719         IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40720         IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40721   150   CONTINUE
40722   160   CONTINUE
40723   170   CONTINUE
40724       ENDIF
40725
40726 C...Call Bethe-Heitler term expression for charm and bottom.
40727       CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
40728       XPBEH(4)=XPBH
40729       XPBEH(-4)=XPBH
40730       CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
40731       XPBEH(5)=XPBH
40732       XPBEH(-5)=XPBH
40733
40734 C...For MSbar subtraction call C^gamma term expression for d, u, s.
40735       IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40736         CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
40737         DO 180 KFL=-5,5
40738         XPDIR(KFL)=XPGA(KFL)
40739   180   CONTINUE
40740       ENDIF
40741
40742 C...Store result in output array.
40743       DO 190 KFL=-5,5
40744       CHSQ=1./9.
40745       IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
40746       XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40747       IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40748       XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40749       VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40750   190 CONTINUE
40751
40752       RETURN
40753       END
40754
40755 C*********************************************************************
40756
40757 CDECK  ID>, PHO_SASVMD
40758       SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40759 C...Purpose: to evaluate the VMD parton distributions of a photon,
40760 C...evolved homogeneously from an initial scale P2 to Q2.
40761 C...Does not include dipole suppression factor.
40762 C...ISET is parton distribution set, see above;
40763 C...additionally ISET=0 is used for the evolution of an anomalous photon
40764 C...which branched at a scale P2 and then evolved homogeneously to Q2.
40765 C...ALAM is the 4-flavour Lambda, which is automatically converted
40766 C...to 3- and 5-flavour equivalents as needed.
40767       SAVE
40768       DIMENSION XPGA(-6:6), VXPGA(-6:6)
40769
40770 C  input/output channels
40771       INTEGER LI,LO
40772       COMMON /POINOU/ LI,LO
40773
40774       DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40775
40776 C...Reset output.
40777       DO 100 KFL=-6,6
40778       XPGA(KFL)=0.
40779       VXPGA(KFL)=0.
40780   100 CONTINUE
40781       KFA=IABS(KF)
40782
40783 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40784       ALAM3=ALAM*(PMC/ALAM)**(2./27.)
40785       ALAM5=ALAM*(ALAM/PMB)**(2./23.)
40786       P2EFF=MAX(P2,1.2*ALAM3**2)
40787       IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40788       IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40789       Q2EFF=MAX(Q2,P2EFF)
40790
40791 C...Find number of flavours at lower and upper scale.
40792       NFP=4
40793       IF(P2EFF.LT.PMC**2) NFP=3
40794       IF(P2EFF.GT.PMB**2) NFP=5
40795       NFQ=4
40796       IF(Q2EFF.LT.PMC**2) NFQ=3
40797       IF(Q2EFF.GT.PMB**2) NFQ=5
40798
40799 C...Find s as sum of 3-, 4- and 5-flavour parts.
40800       S=0.
40801       IF(NFP.EQ.3) THEN
40802         Q2DIV=PMC**2
40803         IF(NFQ.EQ.3) Q2DIV=Q2EFF
40804         S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40805       ENDIF
40806       IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40807         P2DIV=P2EFF
40808         IF(NFP.EQ.3) P2DIV=PMC**2
40809         Q2DIV=Q2EFF
40810         IF(NFQ.EQ.5) Q2DIV=PMB**2
40811         S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40812       ENDIF
40813       IF(NFQ.EQ.5) THEN
40814         P2DIV=PMB**2
40815         IF(NFP.EQ.5) P2DIV=P2EFF
40816         S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40817       ENDIF
40818
40819 C...Calculate frequent combinations of x and s.
40820       X1=1.-X
40821       XL=-LOG(X)
40822       S2=S**2
40823       S3=S**3
40824       S4=S**4
40825
40826 C...Evaluate homogeneous anomalous parton distributions below or
40827 C...above threshold.
40828       IF(ISET.EQ.0) THEN
40829       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40830      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40831         XVAL = X * 1.5 * (X**2+X1**2)
40832         XGLU = 0.
40833         XSEA = 0.
40834       ELSE
40835         XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
40836      &  (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
40837      &  X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
40838         XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
40839      &  X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
40840      &  ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
40841         XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
40842      &  X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
40843      &  ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
40844      &  (2.*X-1.)*X*XL**2)
40845       ENDIF
40846
40847 C...Evaluate set 1D parton distributions below or above threshold.
40848       ELSEIF(ISET.EQ.1) THEN
40849       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40850      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40851         XVAL = 1.294 * X**0.80 * X1**0.76
40852         XGLU = 1.273 * X**0.40 * X1**1.76
40853         XSEA = 0.100 * X1**3.76
40854       ELSE
40855         XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
40856      &  X1**(0.76+0.667*S) * XL**(2.*S)
40857         XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
40858      &  X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
40859      &  1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
40860         XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
40861      &  X**(-7.32*S2/(1.+10.3*S2)) *
40862      &  X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
40863         XSEA0 = 0.100 * X1**3.76
40864       ENDIF
40865
40866 C...Evaluate set 1M parton distributions below or above threshold.
40867       ELSEIF(ISET.EQ.2) THEN
40868       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40869      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40870         XVAL = 0.8477 * X**0.51 * X1**1.37
40871         XGLU = 3.42 * X**0.255 * X1**2.37
40872         XSEA = 0.
40873       ELSE
40874         XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
40875      &  * X1**1.37 * XL**(2.667*S)
40876         XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
40877      &  X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
40878      &  XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
40879      &  X1**(2.37+3.*S)
40880         XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
40881      &  X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
40882      &  XL**(2.8*S)
40883         XSEA0 = 0.
40884       ENDIF
40885
40886 C...Evaluate set 2D parton distributions below or above threshold.
40887       ELSEIF(ISET.EQ.3) THEN
40888       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40889      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40890         XVAL = X**0.46 * X1**0.64 + 0.76 * X
40891         XGLU = 1.925 * X1**2
40892         XSEA = 0.242 * X1**4
40893       ELSE
40894         XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
40895      &  * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
40896      &  (0.76+0.4*S) * X * X1**(2.667*S)
40897         XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
40898      &  EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
40899      &  * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
40900         XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
40901      &  X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
40902         XSEA0 = 0.242 * X1**4
40903       ENDIF
40904
40905 C...Evaluate set 2M parton distributions below or above threshold.
40906       ELSEIF(ISET.EQ.4) THEN
40907       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40908      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40909         XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
40910         XGLU = 1.808 * X1**2
40911         XSEA = 0.209 * X1**4
40912       ELSE
40913         XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
40914      &  X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
40915      &  X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
40916      &  (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
40917         XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
40918      &  X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
40919      &  X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
40920      &  XL**(10.9*S/(1.+2.5*S))
40921         XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
40922      &  X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
40923      &  X1**(4.+S) * XL**(0.45*S)
40924         XSEA0 = 0.209 * X1**4
40925       ENDIF
40926       ENDIF
40927
40928 C...Threshold factors for c and b sea.
40929       SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40930       XCHM=0.
40931       IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
40932         SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40933         IF(ISET.EQ.0) THEN
40934           XCHM=XSEA*(1.-(SCH/SLL)**2)
40935         ELSE
40936           XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
40937         ENDIF
40938       ENDIF
40939       XBOT=0.
40940       IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
40941         SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40942         IF(ISET.EQ.0) THEN
40943           XBOT=XSEA*(1.-(SBT/SLL)**2)
40944         ELSE
40945           XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
40946         ENDIF
40947       ENDIF
40948
40949 C...Fill parton distributions.
40950       XPGA(0)=XGLU
40951       XPGA(1)=XSEA
40952       XPGA(2)=XSEA
40953       XPGA(3)=XSEA
40954       XPGA(4)=XCHM
40955       XPGA(5)=XBOT
40956       XPGA(KFA)=XPGA(KFA)+XVAL
40957       DO 110 KFL=1,5
40958       XPGA(-KFL)=XPGA(KFL)
40959   110 CONTINUE
40960       VXPGA(KFA)=XVAL
40961       VXPGA(-KFA)=XVAL
40962
40963       RETURN
40964       END
40965
40966 C*********************************************************************
40967
40968 CDECK  ID>, PHO_SASANO
40969       SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40970 C...Purpose: to evaluate the parton distributions of the anomalous
40971 C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
40972 C...to Q2.
40973 C...KF=0 gives the sum over (up to) 5 flavours,
40974 C...KF<0 limits to flavours up to abs(KF),
40975 C...KF>0 is for flavour KF only.
40976 C...ALAM is the 4-flavour Lambda, which is automatically converted
40977 C...to 3- and 5-flavour equivalents as needed.
40978       SAVE
40979
40980 C  input/output channels
40981       INTEGER LI,LO
40982       COMMON /POINOU/ LI,LO
40983
40984       DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40985       DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40986
40987 C...Reset output.
40988       DO 100 KFL=-6,6
40989       XPGA(KFL)=0.
40990       VXPGA(KFL)=0.
40991   100 CONTINUE
40992       IF(Q2.LE.P2) RETURN
40993       KFA=IABS(KF)
40994
40995 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40996       ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
40997       ALAMSQ(4)=ALAM**2
40998       ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
40999       P2EFF=MAX(P2,1.2*ALAMSQ(3))
41000       IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
41001       IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
41002       Q2EFF=MAX(Q2,P2EFF)
41003       XL=-LOG(X)
41004
41005 C...Find number of flavours at lower and upper scale.
41006       NFP=4
41007       IF(P2EFF.LT.PMC**2) NFP=3
41008       IF(P2EFF.GT.PMB**2) NFP=5
41009       NFQ=4
41010       IF(Q2EFF.LT.PMC**2) NFQ=3
41011       IF(Q2EFF.GT.PMB**2) NFQ=5
41012
41013 C...Define range of flavour loop.
41014       IF(KF.EQ.0) THEN
41015         KFLMN=1
41016         KFLMX=5
41017       ELSEIF(KF.LT.0) THEN
41018         KFLMN=1
41019         KFLMX=KFA
41020       ELSE
41021         KFLMN=KFA
41022         KFLMX=KFA
41023       ENDIF
41024
41025 C...Loop over flavours the photon can branch into.
41026       DO 110 KFL=KFLMN,KFLMX
41027
41028 C...Light flavours: calculate t range and (approximate) s range.
41029       IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
41030         TDIFF=LOG(Q2EFF/P2EFF)
41031         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41032      &  LOG(P2EFF/ALAMSQ(NFQ)))
41033         IF(NFQ.GT.NFP) THEN
41034           Q2DIV=PMB**2
41035           IF(NFQ.EQ.4) Q2DIV=PMC**2
41036           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41037      &    LOG(P2EFF/ALAMSQ(NFQ)))
41038           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41039      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
41040           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41041         ENDIF
41042         IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41043           Q2DIV=PMC**2
41044           SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41045      &    LOG(P2EFF/ALAMSQ(4)))
41046           SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41047      &    LOG(P2EFF/ALAMSQ(3)))
41048           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41049         ENDIF
41050
41051 C...u and s quark do not need a separate treatment when d has been done.
41052       ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41053
41054 C...Charm: as above, but only include range above c threshold.
41055       ELSEIF(KFL.EQ.4) THEN
41056         IF(Q2.LE.PMC**2) GOTO 110
41057         P2EFF=MAX(P2EFF,PMC**2)
41058         Q2EFF=MAX(Q2EFF,P2EFF)
41059         TDIFF=LOG(Q2EFF/P2EFF)
41060         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41061      &  LOG(P2EFF/ALAMSQ(NFQ)))
41062         IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41063           Q2DIV=PMB**2
41064           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41065      &    LOG(P2EFF/ALAMSQ(NFQ)))
41066           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41067      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
41068           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41069         ENDIF
41070
41071 C...Bottom: as above, but only include range above b threshold.
41072       ELSEIF(KFL.EQ.5) THEN
41073         IF(Q2.LE.PMB**2) GOTO 110
41074         P2EFF=MAX(P2EFF,PMB**2)
41075         Q2EFF=MAX(Q2,P2EFF)
41076         TDIFF=LOG(Q2EFF/P2EFF)
41077         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41078      &  LOG(P2EFF/ALAMSQ(NFQ)))
41079       ENDIF
41080
41081 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41082       CHSQ=1./9.
41083       IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41084       FAC=AEM2PI*2.*CHSQ*TDIFF
41085
41086 C...Evaluate parton distributions (normalized to unit momentum sum).
41087       IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41088         XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41089      &  (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41090      &  1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41091      &  X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41092         XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41093      &  X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41094      &  ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41095         XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41096      &  X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41097      &  ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41098      &  (2.*X-1.)*X*XL**2)
41099
41100 C...Threshold factors for c and b sea.
41101         SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41102         XCHM=0.
41103         IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41104           SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41105           XCHM=XSEA*(1.-(SCH/SLL)**3)
41106         ENDIF
41107         XBOT=0.
41108         IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41109           SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41110           XBOT=XSEA*(1.-(SBT/SLL)**3)
41111         ENDIF
41112       ENDIF
41113
41114 C...Add contribution of each valence flavour.
41115       XPGA(0)=XPGA(0)+FAC*XGLU
41116       XPGA(1)=XPGA(1)+FAC*XSEA
41117       XPGA(2)=XPGA(2)+FAC*XSEA
41118       XPGA(3)=XPGA(3)+FAC*XSEA
41119       XPGA(4)=XPGA(4)+FAC*XCHM
41120       XPGA(5)=XPGA(5)+FAC*XBOT
41121       XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41122       VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41123   110 CONTINUE
41124       DO 120 KFL=1,5
41125       XPGA(-KFL)=XPGA(KFL)
41126       VXPGA(-KFL)=VXPGA(KFL)
41127   120 CONTINUE
41128
41129       END
41130
41131 C*********************************************************************
41132
41133 CDECK  ID>, PHO_SASBEH
41134       SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41135 C...Purpose: to evaluate the Bethe-Heitler cross section for
41136 C...heavy flavour production.
41137       SAVE
41138       DATA AEM2PI/0.0011614/
41139
41140 C...Reset output.
41141       XPBH=0.
41142       SIGBH=0.
41143
41144 C...Check kinematics limits.
41145       IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41146       W2=Q2*(1.-X)/X-P2
41147       BETA2=1.-4.*PM2/W2
41148       IF(BETA2.LT.1E-10) RETURN
41149       BETA=SQRT(BETA2)
41150       RMQ=4.*PM2/Q2
41151
41152 C...Simple case: P2 = 0.
41153       IF(P2.LT.1E-4) THEN
41154         IF(BETA.LT.0.99) THEN
41155           XBL=LOG((1.+BETA)/(1.-BETA))
41156         ELSE
41157           XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41158         ENDIF
41159         SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41160      &  XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41161
41162 C...Complicated case: P2 > 0, based on approximation of
41163 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41164       ELSE
41165         RPQ=1.-4.*X**2*P2/Q2
41166         IF(RPQ.GT.1E-10) THEN
41167           RPBE=SQRT(RPQ*BETA2)
41168           IF(RPBE.LT.0.99) THEN
41169             XBL=LOG((1.+RPBE)/(1.-RPBE))
41170             XBI=2.*RPBE/(1.-RPBE**2)
41171           ELSE
41172             RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41173             XBL=LOG((1.+RPBE)**2/RPBESN)
41174             XBI=2.*RPBE/RPBESN
41175           ENDIF
41176           SIGBH=BETA*(6.*X*(1.-X)-1.)+
41177      &    XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41178      &    XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41179         ENDIF
41180       ENDIF
41181
41182 C...Multiply by charge-squared etc. to get parton distribution.
41183       CHSQ=1./9.
41184       IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41185       XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41186
41187       END
41188
41189 C*********************************************************************
41190
41191 CDECK  ID>, PHO_SASDIR
41192       SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41193 C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41194 C...as needed in MSbar parametrizations.
41195       SAVE
41196       DIMENSION XPGA(-6:6)
41197       DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41198
41199 C...Reset output.
41200       DO 100 KFL=-6,6
41201       XPGA(KFL)=0.
41202   100 CONTINUE
41203
41204 C...Evaluate common x-dependent expression.
41205       XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41206       CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41207
41208 C...d, u, s part by simple charge factor.
41209       XPGA(1)=(1./9.)*CGAM
41210       XPGA(2)=(4./9.)*CGAM
41211       XPGA(3)=(1./9.)*CGAM
41212
41213 C...Also fill for antiquarks.
41214       DO 110 KF=1,5
41215       XPGA(-KF)=XPGA(KF)
41216   110 CONTINUE
41217
41218       END
41219
41220 CDECK  ID>, PHO_PHGAL
41221       SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41222 C***********************************************************************
41223 C
41224 C     photon parton densities with built-in momentum sum rule and
41225 C     Regge-based low-x behaviour
41226 C
41227 C     H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41228 C     e-Print Archive: hep-ph/9711355
41229 C
41230 C     code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41231 C
41232 C***********************************************************************
41233       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41234       SAVE
41235
41236       PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41237       DOUBLE PRECISION
41238      &       XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41239      &       XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41240
41241       DIMENSION NA(NARG)
41242
41243       DATA ZEROD/0.D0/
41244
41245 C...100 x values; in (D-4,.77) log spaced (78 points)
41246 C...              in (.78,.995) lineary spaced (22 points)
41247       DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41248       DATA XT/
41249      &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41250      &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41251      &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41252      &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41253      &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41254      &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41255      &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41256      &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41257      &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41258      &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41259      &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41260      &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41261      &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41262      &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41263      &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41264      &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41265      &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41266
41267 C...place for DATA blocks
41268       DATA (XPV(I,1,0),I=1,100)/
41269      &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41270      &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41271      &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41272      &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41273      &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41274      &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41275      &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41276      &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41277      &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41278      &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41279      &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41280      &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41281      &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41282      &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41283      &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41284      &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41285      &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41286       DATA (XPV(I,1,1),I=1,100)/
41287      &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41288      &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41289      &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41290      &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41291      &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41292      &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41293      &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41294      &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41295      &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41296      &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41297      &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41298      &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41299      &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41300      &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41301      &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41302      &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41303      &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41304       DATA (XPV(I,1,2),I=1,100)/
41305      &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41306      &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41307      &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41308      &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41309      &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41310      &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41311      &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41312      &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41313      &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41314      &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41315      &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41316      &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41317      &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41318      &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41319      &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41320      &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41321      &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41322       DATA (XPV(I,1,3),I=1,100)/
41323      &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41324      &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41325      &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41326      &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41327      &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41328      &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41329      &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41330      &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41331      &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41332      &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41333      &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41334      &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41335      &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41336      &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41337      &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41338      &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41339      &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41340       DATA (XPV(I,1,4),I=1,100)/
41341      &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41342      &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41343      &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41344      &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41345      &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41346      &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41347      &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41348      &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41349      &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41350      &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41351      &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41352      &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41353      &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41354      &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41355      &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41356      &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41357      &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41358       DATA (XPV(I,2,0),I=1,100)/
41359      &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41360      &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41361      &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41362      &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41363      &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41364      &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41365      &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41366      &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41367      &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41368      &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41369      &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41370      &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41371      &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41372      &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41373      &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41374      &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41375      &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41376       DATA (XPV(I,2,1),I=1,100)/
41377      &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41378      &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41379      &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41380      &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41381      &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41382      &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41383      &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41384      &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41385      &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41386      &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41387      &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41388      &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41389      &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41390      &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41391      &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41392      &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41393      &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41394       DATA (XPV(I,2,2),I=1,100)/
41395      &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41396      &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41397      &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41398      &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41399      &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41400      &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41401      &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41402      &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41403      &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41404      &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41405      &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41406      &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41407      &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41408      &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41409      &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41410      &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41411      &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41412       DATA (XPV(I,2,3),I=1,100)/
41413      &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41414      &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41415      &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41416      &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41417      &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41418      &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41419      &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41420      &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41421      &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41422      &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41423      &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41424      &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41425      &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41426      &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41427      &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41428      &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41429      &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41430       DATA (XPV(I,2,4),I=1,100)/
41431      &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41432      &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41433      &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41434      &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41435      &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41436      &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41437      &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41438      &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41439      &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41440      &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41441      &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41442      &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41443      &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41444      &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41445      &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41446      &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41447      &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41448       DATA (XPV(I,3,0),I=1,100)/
41449      &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41450      &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41451      &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41452      &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41453      &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41454      &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41455      &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41456      &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41457      &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41458      &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41459      &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41460      &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41461      &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41462      &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41463      &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41464      &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41465      &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41466       DATA (XPV(I,3,1),I=1,100)/
41467      &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41468      &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41469      &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41470      &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41471      &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41472      &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41473      &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41474      &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41475      &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41476      &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41477      &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41478      &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41479      &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41480      &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41481      &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41482      &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41483      &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41484       DATA (XPV(I,3,2),I=1,100)/
41485      &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41486      &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41487      &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41488      &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41489      &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41490      &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41491      &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41492      &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41493      &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41494      &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41495      &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41496      &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41497      &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41498      &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41499      &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41500      &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41501      &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41502       DATA (XPV(I,3,3),I=1,100)/
41503      &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41504      &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41505      &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41506      &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41507      &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41508      &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41509      &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41510      &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41511      &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41512      &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41513      &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41514      &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41515      &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41516      &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41517      &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41518      &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41519      &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41520       DATA (XPV(I,3,4),I=1,100)/
41521      &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41522      &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41523      &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41524      &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41525      &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41526      &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41527      &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41528      &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41529      &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41530      &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41531      &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41532      &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41533      &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41534      &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41535      &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41536      &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41537      &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41538       DATA (XPV(I,4,0),I=1,100)/
41539      &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41540      &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41541      &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41542      &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41543      &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41544      &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41545      &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41546      &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41547      &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41548      &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41549      &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41550      &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41551      &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41552      &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41553      &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41554      &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41555      &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41556       DATA (XPV(I,4,1),I=1,100)/
41557      &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41558      &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41559      &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41560      &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41561      &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41562      &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41563      &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41564      &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41565      &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41566      &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41567      &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41568      &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41569      &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41570      &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41571      &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41572      &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41573      &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41574       DATA (XPV(I,4,2),I=1,100)/
41575      &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41576      &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41577      &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41578      &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41579      &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41580      &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41581      &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41582      &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41583      &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41584      &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41585      &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41586      &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41587      &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41588      &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
41589      &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
41590      &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
41591      &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
41592       DATA (XPV(I,4,3),I=1,100)/
41593      &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
41594      &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
41595      &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
41596      &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
41597      &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
41598      &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
41599      &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
41600      &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
41601      &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
41602      &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
41603      &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
41604      &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
41605      &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
41606      &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
41607      &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
41608      &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
41609      &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
41610       DATA (XPV(I,4,4),I=1,100)/
41611      &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
41612      &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
41613      &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
41614      &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
41615      &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
41616      &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
41617      &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
41618      &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
41619      &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
41620      &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
41621      &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
41622      &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
41623      &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
41624      &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
41625      &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
41626      &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
41627      &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
41628       DATA (XPV(I,5,0),I=1,100)/
41629      &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
41630      &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
41631      &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
41632      &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
41633      &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
41634      &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
41635      &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
41636      &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
41637      &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
41638      &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
41639      &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
41640      &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
41641      &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
41642      &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
41643      &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
41644      &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
41645      &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
41646       DATA (XPV(I,5,1),I=1,100)/
41647      &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
41648      &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
41649      &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
41650      &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
41651      &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
41652      &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
41653      &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
41654      &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
41655      &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
41656      &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
41657      &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
41658      &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
41659      &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
41660      &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
41661      &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
41662      &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
41663      &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
41664       DATA (XPV(I,5,2),I=1,100)/
41665      &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
41666      &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
41667      &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
41668      &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
41669      &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
41670      &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
41671      &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
41672      &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
41673      &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
41674      &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
41675      &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
41676      &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
41677      &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
41678      &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
41679      &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
41680      &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
41681      &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
41682       DATA (XPV(I,5,3),I=1,100)/
41683      &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
41684      &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
41685      &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
41686      &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
41687      &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
41688      &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
41689      &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
41690      &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
41691      &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
41692      &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
41693      &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
41694      &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
41695      &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
41696      &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
41697      &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
41698      &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
41699      &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
41700       DATA (XPV(I,5,4),I=1,100)/
41701      &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
41702      &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
41703      &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
41704      &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
41705      &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
41706      &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
41707      &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
41708      &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
41709      &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
41710      &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
41711      &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
41712      &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
41713      &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
41714      &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
41715      &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
41716      &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
41717      &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
41718       DATA (XPV(I,6,0),I=1,100)/
41719      &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
41720      &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
41721      &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
41722      &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
41723      &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
41724      &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
41725      &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
41726      &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
41727      &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
41728      &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
41729      &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
41730      &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
41731      &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
41732      &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
41733      &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
41734      &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
41735      &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
41736       DATA (XPV(I,6,1),I=1,100)/
41737      &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
41738      &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
41739      &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
41740      &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
41741      &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
41742      &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
41743      &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
41744      &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
41745      &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
41746      &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
41747      &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
41748      &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
41749      &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
41750      &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
41751      &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
41752      &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
41753      &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
41754       DATA (XPV(I,6,2),I=1,100)/
41755      &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
41756      &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
41757      &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
41758      &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
41759      &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
41760      &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
41761      &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
41762      &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
41763      &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
41764      &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
41765      &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
41766      &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
41767      &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
41768      &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
41769      &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
41770      &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
41771      &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
41772       DATA (XPV(I,6,3),I=1,100)/
41773      &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
41774      &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
41775      &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
41776      &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
41777      &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
41778      &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
41779      &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
41780      &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
41781      &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
41782      &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
41783      &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
41784      &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
41785      &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
41786      &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
41787      &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
41788      &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
41789      &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
41790       DATA (XPV(I,6,4),I=1,100)/
41791      &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
41792      &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
41793      &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
41794      &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
41795      &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
41796      &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
41797      &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
41798      &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
41799      &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
41800      &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
41801      &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
41802      &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
41803      &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
41804      &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
41805      &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
41806      &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
41807      &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
41808       DATA (XPV(I,7,0),I=1,100)/
41809      &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
41810      &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
41811      &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
41812      &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
41813      &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
41814      &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
41815      &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
41816      &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
41817      &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
41818      &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
41819      &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
41820      &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
41821      &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
41822      &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
41823      &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
41824      &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
41825      &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
41826       DATA (XPV(I,7,1),I=1,100)/
41827      &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
41828      &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
41829      &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
41830      &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
41831      &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
41832      &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
41833      &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
41834      &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
41835      &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
41836      &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
41837      &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
41838      &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
41839      &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
41840      &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
41841      &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
41842      &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
41843      &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
41844       DATA (XPV(I,7,2),I=1,100)/
41845      &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
41846      &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
41847      &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
41848      &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
41849      &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
41850      &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
41851      &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
41852      &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
41853      &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
41854      &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
41855      &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
41856      &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
41857      &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
41858      &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
41859      &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
41860      &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
41861      &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
41862       DATA (XPV(I,7,3),I=1,100)/
41863      &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
41864      &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
41865      &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
41866      &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
41867      &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
41868      &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
41869      &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
41870      &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
41871      &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
41872      &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
41873      &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
41874      &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
41875      &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
41876      &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
41877      &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
41878      &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
41879      &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
41880       DATA (XPV(I,7,4),I=1,100)/
41881      &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
41882      &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
41883      &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
41884      &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
41885      &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
41886      &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
41887      &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
41888      &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
41889      &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
41890      &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
41891      &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
41892      &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
41893      &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
41894      &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
41895      &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
41896      &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
41897      &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
41898
41899 C..fetching pdfs
41900       DO  5 IP=-6,6
41901         XPDF(IP)=ZEROD
41902  5    CONTINUE
41903       DO 2 I=1,IX
41904         ENT(I)=LOG10(XT(I))
41905   2   CONTINUE
41906       NA(1)=IX
41907       NA(2)=IQ
41908       DO 3 I=1,IQ
41909         ENT(IX+I)=LOG10(Q2T(I))
41910    3  CONTINUE
41911       ARG(1)=LOG10(X)
41912       ARG(2)=LOG10(Q2)
41913 C..various flavours (u-->2,d-->1)
41914       XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
41915       XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
41916       XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
41917       XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
41918       XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
41919       DO 21 JF=1,4
41920         XPDF(-JF)=XPDF(JF)
41921  21   CONTINUE
41922
41923       END
41924
41925 CDECK  ID>, PHO_DBFINT
41926       DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
41927 C***********************************************************************
41928 C
41929 C     routine based on CERN library E104
41930 C
41931 C     multi-dimensional interpolation routine, needed for PHOJET
41932 C     internal cross section tables and several PDF sets (GRV98 and AGL)
41933 C
41934 C     changed to avoid recursive function calls (R.Engel, 09/98)
41935 C
41936 C***********************************************************************
41937       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41938       SAVE
41939
41940       INTEGER NA(NARG), INDEX(32)
41941       DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
41942
41943       DATA ZEROD/0.D0/
41944       DATA ONED/1.D0/
41945
41946       DBFINT    =  ZEROD
41947       PHO_DBFINT =  ZEROD
41948       IF(NARG .LT. 1  .OR.  NARG .GT. 5)  RETURN
41949
41950            LMAX      =  0
41951            ISTEP     =  1
41952            KNOTS     =  1
41953            INDEX(1)  =  1
41954            WEIGHT(1) =  ONED
41955            DO 100    N  =  1, NARG
41956               X     =  ARG(N)
41957               NDIM  =  NA(N)
41958               LOCA  =  LMAX
41959               LMIN  =  LMAX + 1
41960               LMAX  =  LMAX + NDIM
41961               IF(NDIM .GT. 2)  GOTO 10
41962               IF(NDIM .EQ. 1)  GOTO 100
41963               H  =  X - ENT(LMIN)
41964               IF(H .EQ. ZEROD)  GOTO 90
41965               ISHIFT  =  ISTEP
41966               IF(X-ENT(LMIN+1) .EQ. ZEROD)  GOTO 21
41967               ISHIFT  =  0
41968               ETA     =  H / (ENT(LMIN+1) - ENT(LMIN))
41969               GOTO 30
41970    10         LOCB  =  LMAX + 1
41971    11         LOCC  =  (LOCA+LOCB) / 2
41972               IF(X-ENT(LOCC))  12, 20, 13
41973    12         LOCB  =  LOCC
41974               GOTO 14
41975    13         LOCA  =  LOCC
41976    14         IF(LOCB-LOCA .GT. 1)  GOTO 11
41977               LOCA    =  MIN ( MAX (LOCA,LMIN), LMAX-1 )
41978               ISHIFT  =  (LOCA - LMIN) * ISTEP
41979               ETA     =  (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
41980               GOTO 30
41981    20         ISHIFT  =  (LOCC - LMIN) * ISTEP
41982    21         DO 22  K  =  1, KNOTS
41983                  INDEX(K)  =  INDEX(K) + ISHIFT
41984    22         CONTINUE
41985               GOTO 90
41986    30         DO 31  K  =  1, KNOTS
41987                  INDEX(K)         =  INDEX(K) + ISHIFT
41988                  INDEX(K+KNOTS)   =  INDEX(K) + ISTEP
41989                  WEIGHT(K+KNOTS)  =  WEIGHT(K) * ETA
41990                  WEIGHT(K)        =  WEIGHT(K) - WEIGHT(K+KNOTS)
41991    31         CONTINUE
41992               KNOTS  =  2*KNOTS
41993    90         ISTEP  =  ISTEP * NDIM
41994   100      CONTINUE
41995            DO 200    K  =  1, KNOTS
41996               I  =  INDEX(K)
41997               DBFINT =  DBFINT + WEIGHT(K) * TABLE(I)
41998   200      CONTINUE
41999
42000       PHO_DBFINT = DBFINT
42001
42002       END
42003
42004 CDECK  ID>, PHVAL
42005       SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
42006 C**********************************************************************
42007 C
42008 C   dummy subroutine, remove to link PHOLIB
42009 C
42010 C**********************************************************************
42011       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42012       DIMENSION PD(-6:6)
42013       END