]> git.uio.no Git - u/mrichter/AliRoot.git/blame - DPMJET/phojet1.12-35c.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Declaration of AliGenPythia added.
[u/mrichter/AliRoot.git] / DPMJET / phojet1.12-35c.f
CommitLineData
d30b8254 1C***********************************************************************
2C
3C
4C
5C PHOJET version 1.12
6C -------------------
7C
8C
9C ($Revision$, $Date$)
10C
11C
12C Authors: Ralph Engel
13C (eng@lepton.bartol.udel.edu)
14C
15C Johannes Ranft
16C (johannes.ranft@cern.ch)
17C
18C Stefan Roesler
19C (sroesler@SLAC.Stanford.EDU)
20C
21C
22C For the latest version and documentation check
23C http://lepton.bartol.udel.edu/~eng/phojet.html
24C
25C
26C Bug reports, questions, complaints are welcome
27C (please send a mail to eng@lepton.bartol.udel).
28C
29C
30C Note that the code is available with several interfaces to
31C Lund fragmentation programs (JETSET7.x, 1.x and a double
32C precision JETSET version). This file is the code with
33C
34
35C interface to PYTHIA 6.1 (or higher)
36
37C for usage in DPMJET 3.x (Lund common block dimensions increased)
38
39C
40C***********************************************************************
41C
42C
43C List of subroutines and functions
44C ---------------------------------
45C
46C
47C main event simulation routines
48C
49C PHO_EVENT
50C PHO_PARTON
51C PHO_POSPOM
52C
53C PHO_STDPAR
54C PHO_POMSCA
55C
56C
57C user steering interface
58C
59C PHO_SETMDL
60C PHO_PRESEL
61C
62C
63C experimental setup / photon flux calculation
64C
65C PHO_FIXLAB
66C PHO_FIXCOL
67C PHO_GPHERA
68C PHO_GGEPEM
69C PHO_WGEPEM
70C PHO_GGBLSR
71C PHO_GGBEAM
72C PHO_GGHIOF
73C PHO_GGHIOG
74C PHO_GGFLCL
75C PHO_GGFLCR
76C PHO_GGFAUX
77C PHO_GGFNUC
78C PHO_GHHIOF
79C PHO_GHHIAS
80C
81C
82C initialization
83C
84C PHO_INIT
85C PHO_DATINI
86C PHO_PARDAT
87C PHO_MCINI
88C
89C PHO_EVEINI
90C
91C PHO_HARINI
92C PHO_FRAINI
93C
94C PHO_FITPAR
95C
96C
97C cross section calculation
98C
99C PHO_CSINT
100C
101C PHO_XSECT
102C PHO_BORNCS
103C PHO_HARXTO
104C
105C PHO_DSIGDT
106C
107C PHO_TRIREG
108C PHO_LOOREG
109C PHO_TRXPOM
110C
111C PHO_EIKON
112C PHO_CHAN2A
113C
114C PHO_SCALES
115C
116C
117C multiple interaction structure
118C
119C PHO_IMPAMP
120C PHO_PRBDIS
121C PHO_SAMPRO
122C PHO_SAMPRB
123C
124C
125C hadron / photon remnant treatment, soft x selection
126C
127C PHO_HARREM
128C PHO_PARREM
129C
130C PHO_HADSP2
131C PHO_HADSP3
132C PHO_SOFTXX
133C PHO_SELSXR
134C PHO_SELSX2
135C PHO_SELSXS
136C PHO_SELSXI
137C
138C PHO_VALFLA
139C PHO_REGFLA
140C PHO_SEAFLA
141C PHO_FLAUX
142C PHO_BETAF
143C IPHO_DIQU
144C
145C
146C primordial kt and soft parton pt
147C
148C PHO_PRIMKT
149C PHO_PARTPT
150C PHO_SOFTPT
151C PHO_SELPT
152C
153C PHO_CONN0
154C PHO_CONN1
155C
156C
157C simulation of hard scattering, initial state radiation
158C
159C PHO_HARCOL
160C PHO_SELCOL
161C PHO_HARCOR
162C
163C PHO_HARDIR
164C PHO_HARX12
165C PHO_HARDX1
166C PHO_HARKIN
167C PHO_HARWGH
168C PHO_HARSCA
169C PHO_HARFAC
170C PHO_HARWGX
171C PHO_HARWGI
172C PHO_HARINT
173C PHO_HARMCI
174C
175C PHO_HARXR3
176C PHO_HARXR2
177C PHO_HARXD2
178C PHO_HARXPT
179C PHO_HARISR
180C PHO_HARZSP
181C
182C PHO_PTCUT
183C PHO_ALPHAE
184C PHO_ALPHAS
185C
186C
187C diffraction dissociation
188C
189C PHO_DIFDIS
190C PHO_DIFPRO
191C PHO_DIFPAR
192C PHO_QELAST
193C PHO_CDIFF
194C PHO_DFWRAP
195C
196C PHO_SAMASS
197C PHO_DSIGDM
198C PHO_DFMASS
199C
200C PHO_SDECAY
201C PHO_SDECY2
202C PHO_SDECY3
203C
204C PHO_DIFSLP
205C PHO_DIFKIN
206C PHO_VECRES
207C PHO_DIFRES
208C
209C PHO_REGPAR
210C
211C PHO_PECMS
212C PHO_SETPAR
213C
214C
215C fragmentation, treatment of low-mass strings
216C
217C PHO_STRING
218C PHO_STRFRA
219C
220C PHO_ID2STR
221C PHO_MCHECK
222C PHO_POMCOR
223C PHO_MASCOR
224C PHO_PARCOR
225C
226C PHO_GLU2QU
227C PHO_GLUSPL
228C
229C PHO_DQMASS
230C PHO_BAMASS
231C PHO_MEMASS
232C
233C
234C particle code tables, particle numbering conversion
235C
236C PHO_PNAME
237C PHO_PMASS
238C IPHO_CHR3
239C IPHO_BAR3
240C
241C IPHO_ANTI
242C
243C IPHO_PDG2ID
244C IPHO_ID2PDG
245C IPHO_LU2PDG
246C IPHO_PDG2LU
247C
248C IPHO_CNV1
249C PHO_HACODE
250C
251C
252C
253C Lorentz transformations, rotations and mass adjustment
254C
255C PHO_ALTRA
256C PHO_LTRANS
257C PHO_TRANS
258C PHO_TRANI
259C
260C PHO_MKSLTR
261C PHO_GETLTR
262C
263C PHO_LTRHEP
264C
265C PHO_MSHELL
266C PHO_MASSAD
267C
268C
269C program debugging and internal cross-checks
270C
271C PHO_PREVNT
272C PHO_PRSTRG
273C PHO_CHECK
274C
275C PHO_TRACE
276C
277C PHO_REJSTA
278C
279C PHO_ABORT
280C
281C
282C cross section fitting
283C
284C PHO_FITMAI
285C PHO_FITINP
286C PHO_FITDAT
287C PHO_FITOUT
288C PHO_FITAMP
289C PHO_FITTST
290C PHO_FITMSQ
291C PHO_FITVD1
292C PHO_FITCN1
293C PHO_FITINI
294C
295C
296C cross section parametrizations
297C
298C PHO_HADCSL
299C PHO_ALLM97
300C PHO_CSDIFF
301C
302
303C
304C random numbers
305C
306
307C DPMJET random number generator DT_RNDM used
308
309C
310C PHO_SFECFE
311C PHO_RNDBET
312C PHO_RNDGAM
313C
314C
315C auxiliary routines / numerical methods
316C
317C PHO_GAUSET
318C PHO_GAUDAT
319C
320C pho_samp1d
321C
322C PHO_DZEROX
323C PHO_EXPINT
324C PHO_BESSJ0
325C PHO_BESSI0
326C pho_ExpBessI0
327C PHO_BESSI1
328C PHO_BESSK0
329C PHO_BESSK1
330C
331C PHO_XLAM
332C
333C PHO_SWAPD
334C PHO_SWAPI
335C
336C
337C parton density parametrization management / interface
338C
339C PHO_PDF
340C
341C PHO_SETPDF
342C PHO_GETPDF
343C PHO_ACTPDF
344C
345C PHO_QPMPDF
346C
347C PHO_PDFTST
348C
349C
350C parton density parametrizations from other authors
351C
352C PHO_DOR98LO
353C PHO_DOR98SC
354C PHO_DOR94LO
355C PHO_DOR94HO
356C PHO_DOR94DI
357C PHO_DOR92LO
358C PHO_DOR92HO
359C PHO_DORPLO
360C PHO_DORPHO
361C PHO_DORGLO
362C PHO_DORGHO
363C PHO_DORGH0
364C PHO_DOR94FV
365C PHO_DOR94FW
366C PHO_DOR94FS
367C PHO_DOR92FV
368C PHO_DOR92FW
369C PHO_DOR92FS
370C PHO_DORFVP
371C PHO_DORFGP
372C PHO_DORFQP
373C PHO_DORGF
374C PHO_DORGFS
375C PHO_grsf1
376C PHO_grsf2
377C
378C PHO_CKMTPA
379C PHO_CKMTPD
380C PHO_CKMTPO
381C PHO_CKMTFV
382C
383C PHO_DBFINT
384C
385C PHO_SASGAM
386C PHO_SASVMD
387C PHO_SASANO
388C PHO_SASBEH
389C PHO_SASDIR
390C
391C PHO_PHGAL
392C PHVAL
393C
394C
395C***********************************************************************
396
397CDECK ID>, PHO_INIT
398**sr temporarily changed
399C SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
400 SUBROUTINE PHO_INIT(LINP,IREJ)
401**
402C***********************************************************************
403C
404C main subroutine to configure and manage PHOJET calculations
405C
406C input: LINP input unit to read from
407C -1 to skip reading of input file
408C LOUT output unit to write to
409C
410C output: IREJ 0 success
411C 1 failure
412C
413C***********************************************************************
414 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
415 SAVE
416
417C input/output channels
418 INTEGER LI,LO
419 COMMON /POINOU/ LI,LO
420C 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
427C 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)
432C general process information
433 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
434 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
435
436C 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)
440C 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)
445C integration precision for hard cross sections (obsolete)
446 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
447 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
448C 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
452C 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
455C 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
466C 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
474C 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)
479C 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)
484C 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
517C define input/output units
518 IF(LINP.GE.0) THEN
519 LI = LINP
520 ELSE
521 LI = 5
522 ENDIF
523**sr temporarily changed
524C 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
556C standard initializations
557 CALL PHO_DATINI
558 CALL PHO_PARDAT
559 DUM = PHO_PMASS(0,-1)
560
561C initialize standard PDFs
562C proton
563 CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
564 CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
565C neutron
566 CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
567 CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
568C photon
569 CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
570C pomeron
571 CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
572C 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)
576C 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
582C nothing to be done
583 IF(LINP.LT.0) RETURN
584
585C 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
702C 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
709C 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
714C 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
729C 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
741C 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
755C 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
775C 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
786C 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
797C 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
805C 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
816C 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
823C 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
837C 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
844C 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
855CDECK ID>, PHO_SETMDL
856 SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
857C**********************************************************************
858C
859C set model switches
860C
861C input: INDX model parameter number
862C (positive: ISWMDL, negative: IPAMDL)
863C IVAL new value
864C IMODE -1 print value of parameter INDX
865C 1 set new value
866C -2 print current settings
867C
868C**********************************************************************
869 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
870 SAVE
871
872C input/output channels
873 INTEGER LI,LO
874 COMMON /POINOU/ LI,LO
875C 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
882C *** Commented by Chiara
883C WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
884C & '----------------------------'
885 DO 100 I=1,48,3
886 IF(ISWMDL(I).EQ.-9999) GOTO 200
887 IF(ISWMDL(I+1).EQ.-9999) THEN
888C *** Commented by Chiara
889C WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
890 GOTO 200
891 ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
892C WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
893C & I+1,':',MDLNA(I+1),ISWMDL(I+1)
894 GOTO 200
895 ELSE
896C WRITE(LO,'(3(5X,I3,A1,A,I6))')
897C & (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
902C WRITE(LO,'(1X,A,1X,A,I6)')
903C & '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
925CDECK ID>, PHO_DATINI
926 SUBROUTINE PHO_DATINI
927C*********************************************************************
928C
929C initialization of variables and switches
930C
931C*********************************************************************
932 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
933 SAVE
934
935C input/output channels
936 INTEGER LI,LO
937 COMMON /POINOU/ LI,LO
938C 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)
942C 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
949C 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)
954C 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
959C integration precision for hard cross sections (obsolete)
960 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
961 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
962C 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
966C 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
974C 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)
981C 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
992C 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
995C 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)
999C 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)
1004C 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
1008C 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)
1013C general process information
1014 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
1015 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
1016C 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)
1019C 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
1023C 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)
1030C 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)
1035C 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)
1046C 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
1061C initialize /POCONS/
1062 PI = ATAN(1.D0)*4.D0
1063 PI2 = 2.D0*PI
1064 PI4 = 2.D0*PI2
1065C GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
1066 GEV2MB = 0.389365D0
1067C 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
1082C 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
1090C 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
1097C 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
1159C 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
1166C suppression by energy momentum conservation
1167 PARMDL(8) = 9.D0
1168 PARMDL(9) = 7.D0
1169C 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
1179C lower energy limit for initialization
1180 PARMDL(19) = 5.D0
1181C soft pt for hard scattering remnants
1182 PARMDL(20) = 5.D0
1183C low energy beta of soft pt distribution 1
1184 PARMDL(21) = 4.5D0
1185C high energy beta of soft pt distribution 1
1186 PARMDL(22) = 3.0D0
1187C low energy beta of soft pt distribution 0
1188 PARMDL(23) = 2.5D0
1189C high energy beta of soft pt distribution 0
1190 PARMDL(24) = 0.4D0
1191C effective quark mass in photon wave function
1192 PARMDL(25) = 0.2D0
1193C normalization of unevolved Pomeron PDFs
1194 PARMDL(26) = 0.3D0
1195C 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
1204C Q**2 suppression of multiple interactions
1205 PARMDL(35) = 0.59D0
1206C pt cutoff defaults
1207 PARMDL(36) = 2.5D0
1208 PARMDL(37) = 2.5D0
1209 PARMDL(38) = 2.5D0
1210 PARMDL(39) = 2.5D0
1211C enhancement factor for diffractive cross sections
1212 PARMDL(40) = 1.D0
1213 PARMDL(41) = 1.D0
1214 PARMDL(42) = 1.D0
1215C mass in soft pt distribution
1216 PARMDL(43) = 0.D0
1217C maximum of x allowed for leading particle
1218 PARMDL(44) = 0.9D0
1219C max. mass sampled in diffraction
1220 PARMDL(45) = sqrt(0.4D0)
1221C mass threshold in diffraction (2pi mass)
1222 PARMDL(46) = 0.3D0
1223C regularization of slope parameter in diffraction
1224 PARMDL(47) = 4.D0
1225C renormalized intercept for enhanced graphs
1226 PARMDL(48) = 1.08D0
1227C coherence constraint for diff. cross sections
1228 PARMDL(49) = sqrt(0.05D0)
1229C exponents of x distributions
1230C baryon
1231 PARMDL(50) = 1.5D0
1232 PARMDL(51) = -0.5D0
1233 PARMDL(52) = -0.99D0
1234 PARMDL(53) = -0.99D0
1235C meson (non-strangeness part)
1236 PARMDL(54) = -0.5D0
1237 PARMDL(55) = -0.5D0
1238 PARMDL(56) = -0.99D0
1239 PARMDL(57) = -0.99D0
1240C meson (strangeness part)
1241 PARMDL(58) = -0.2D0
1242 PARMDL(59) = -0.2D0
1243 PARMDL(60) = -0.99D0
1244 PARMDL(61) = -0.99D0
1245C 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
1250C ratio beetween triple-pomeron/reggeon couplings grrp/gppp
1251 PARMDL(66) = 10.D0
1252C ratio beetween triple-pomeron/reggeon couplings gppr/gppp
1253 PARMDL(67) = 10.D0
1254C min. abs(t) in diffraction
1255 PARMDL(68) = 0.D0
1256C max. abs(t) in diffraction
1257 PARMDL(69) = 10.D0
1258C min. mass for elastic pomerons in central diffraction
1259 PARMDL(70) = 2.D0
1260C min. mass of diffractive blob in central diffraction
1261 PARMDL(71) = 2.D0
1262C min. Feynman x cut in central diffraction
1263 PARMDL(72) = 0.D0
1264C direct pomeron coupling
1265 PARMDL(74) = 0.D0
1266C relative deviation allowed for energy-momentum conservation
1267C energy-momentum relative deviation
1268 PARMDL(75) = 0.01D0
1269C transverse momentum deviation
1270 PARMDL(76) = 0.01D0
1271C couplings for unitarization in diffraction
1272C non-unitarized pomeron coupling (sqrt(mb))
1273 PARMDL(77) = 3.D0
1274C rescaling factor for pomeron PDF
1275 PARMDL(78) = 3.D0
1276C coupling probabilities
1277 PARMDL(79) = 1.D0
1278 PARMDL(80) = 0.D0
1279C scales to calculate alpha-s of matrix element
1280 PARMDL(81) = 1.D0
1281 PARMDL(82) = 1.D0
1282 PARMDL(83) = 1.D0
1283C scales to calculate alpha-s of initial state radiation
1284 PARMDL(84) = 1.D0
1285 PARMDL(85) = 1.D0
1286 PARMDL(86) = 1.D0
1287C scales to calculate alpha-s of final state radiation
1288 PARMDL(87) = 1.D0
1289 PARMDL(88) = 1.D0
1290 PARMDL(89) = 1.D0
1291C scales to calculate PDFs
1292 PARMDL(90) = 1.D0
1293 PARMDL(91) = 1.D0
1294 PARMDL(92) = 1.D0
1295C scale for ISR starting virtuality
1296 PARMDL(93) = 1.D0
1297C min. virtuality to generate time-like showers in ISR
1298 PARMDL(94) = 2.D0
1299C factor to scale the max. allowed time-like parton shower virtuality
1300 PARMDL(95) = 4.D0
1301C max. transverse momentum for primordial kt
1302 PARMDL(100) = 2.D0
1303C 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
1310C
1311* PARMDL(110-125) reserved for hard scattering
1312C currently chosen scales for hard scattering
1313 DO 10 I=1,16
1314 PARMDL(109+I) = 0.D0
1315 10 CONTINUE
1316C 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
1321C 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
1326C fraction of events without popcorn
1327 PARMDL(134) = -1.D0
1328C fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
1329 PARMDL(135) = 0.5D0
1330C soft color re-connection (fraction)
1331C g g final state
1332 PARMDL(140) = 1.D0/64.D0
1333C g q final state
1334 PARMDL(141) = 1.D0/24.D0
1335C q q final state
1336 PARMDL(142) = 1.D0/9.D0
1337C effective scale in Drees-Godbole like suppresion in photon PDF
1338 PARMDL(144) = 0.766D0**2
1339C 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
1343C 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
1347C 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
1354C min. masses of valence quark
1355 PARMDL(157) = 0.3D0
1356C min. masses of valence diquark
1357 PARMDL(158) = 0.8D0
1358C min. mass of sea quark
1359 PARMDL(159) = 0.D0
1360C suppression of strange quarks as photon valences
1361 PARMDL(160) = 0.2D0
1362C 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
1367C min. momentum fraction for soft processes
1368 PARMDL(165) = 0.3D0
1369C min. phase space for x-sampling
1370 PARMDL(166) = 0.135D0
1371C Ross-Stodolsky exponent
1372 PARMDL(170) = 4.2D0
1373C 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
1382C complex amplitudes, eikonal functions
1383 IPAMDL(1) = 0
1384C allow for Reggeon cuts
1385 IPAMDL(2) = 1
1386C decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
1387 IPAMDL(3) = 0
1388C polarization of photon resonances (0 none, 1 trans, 2 long)
1389 IPAMDL(4) = 1
1390C pt of valence partons
1391 IPAMDL(5) = 1
1392C pt of hard scattering remnant
1393 IPAMDL(6) = 2
1394C running cutoff for hard scattering
1395 IPAMDL(7) = 1
1396C intercept used for the calculation of enhanced graphs
1397 IPAMDL(8) = 1
1398C effective slope of hard scattering amplitde
1399 IPAMDL(9) = 1
1400C mass dependence of slope parameters
1401 IPAMDL(10) = 0
1402C lepton-photon vertex 1
1403 IPAMDL(11) = 0
1404C lepton-photon vertex 2
1405 IPAMDL(12) = 0
1406C call by DPMJET
1407 IPAMDL(13) = 0
1408C method to sample x distributions
1409 IPAMDL(14) = 3
1410C energy-momentum check
1411 IPAMDL(15) = 1
1412C phase space correction for DPMJET interface
1413 IPAMDL(16) = 1
1414C fragment strings from projectile/target/central diff. separately
1415 IPAMDL(17) = 1
1416C method to construct strings for hard interactions
1417 IPAMDL(18) = 1
1418C method to construct strings for soft sea (pomeron cuts)
1419 IPAMDL(19) = 0
1420C method to construct strings in pomeron interactions
1421 IPAMDL(20) = 0
1422C soft color re-connection
1423 IPAMDL(21) = 0
1424C resummation of triple- and loop-Pomeron
1425 IPAMDL(24) = 1
1426C resummation of X iterated triple-Pomeron
1427 IPAMDL(25) = 1
1428C dimension of interpolation table for weights in hard scattering
1429 IPAMDL(30) = Max_tab_E
1430C dimension of interpolation table for pomeron cut distribution
1431 IPAMDL(31) = IEETA1
1432C number of cut soft pomerons (restriction by field dimension)
1433 IPAMDL(32) = IIMAX
1434C number of cut hard pomerons (restriction by field dimension)
1435 IPAMDL(33) = KKMAX
1436C tau pair production in direct photon-photon collisions
1437 IPAMDL(64) = 0
1438C currently chosen scales for hard scattering
1439C ATTENTION: IPAMDL(65-80) reserved for hard scattering!
1440 DO 15 I=1,16
1441 IPAMDL(64+I) = -99999
1442 15 CONTINUE
1443C scales to calculate alpha-s of matrix element
1444 IPAMDL(81) = 1
1445 IPAMDL(82) = 1
1446 IPAMDL(83) = 1
1447C scales to calculate alpha-s of initial state radiation
1448 IPAMDL(84) = 1
1449 IPAMDL(85) = 1
1450 IPAMDL(86) = 1
1451C scales to calculate alpha-s of final state radiation
1452 IPAMDL(87) = 1
1453 IPAMDL(88) = 1
1454 IPAMDL(89) = 1
1455C scales to calculate PDFs
1456 IPAMDL(90) = 1
1457 IPAMDL(91) = 1
1458 IPAMDL(92) = 1
1459C where to get the parameter sets from
1460 IPAMDL(99) = 1
1461C program PHO_ABORT for fatal errors (simulation of division by zero)
1462 IPAMDL(100) = 0
1463C initial state parton showers for all / hardest interaction(s)
1464 IPAMDL(101) = 1
1465C final state parton showers for all / hardest interaction(s)
1466 IPAMDL(102) = 1
1467C initial virtuality for ISR generation
1468 IPAMDL(109) = 1
1469C qqbar-gamma coupling in initial state showers
1470 IPAMDL(110) = 1
1471C generation of time-like showers during ISR
1472 IPAMDL(111) = 1
1473C reweighting of multiple soft contributions for virtual photons
1474 IPAMDL(114) = 1
1475C reweighting / use photon virtuality in photon PDF calculations
1476 IPAMDL(115) = 0
1477C use full QPM model incl. interference terms (direct part in gam-gam)
1478 IPAMDL(116) = 0
1479C matching sigma_tot to F2 as given by parton density at high Q2
1480 IPAMDL(117) = 1
1481C use virtuality of target in F2 calculations (two-gamma only)
1482 IPAMDL(118) = 1
1483C calculation of alpha_em
1484 IPAMDL(120) = 1
1485C strict pt cutoff for gamma-gamma events
1486 IPAMDL(121) = 0
1487C photon virtuality sampled in photon flux approximations
1488 IPAMDL(174) = 1
1489C photon-pomeron: 0,1,2: both,left,right photon emission
1490 IPAMDL(175) = 0
1491C keep full history information in PHOJET-JETSET interface
1492 IPAMDL(178) = 1
1493C max. number of conservation law violations allowed in one run
1494 IPAMDL(179) = 20
1495C selection of soft X values
1496C max. iteration number in PHO_SELSXS
1497 IPAMDL(180) = 50
1498C max. iteration number in PHO_SELSXR
1499 IPAMDL(181) = 200
1500C max. iteration number in PHO_SELSX2
1501 IPAMDL(182) = 100
1502C max. iteration number in PHO_SELSXI
1503 IPAMDL(183) = 50
1504
1505C 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
1513C 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
1524C number of light flavours (quarks treated as massless)
1525 NFS = 4
1526C 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
1533C 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)
1540C initialize /POGAUP/
1541 NGAUP1 = 12
1542 NGAUP2 = 12
1543 NGAUET = 16
1544 NGAUIN = 12
1545 NGAUSO = 96
1546C initialize //
1547 DO 30 I=1,100
1548 IDEB(I) = 0
1549 30 CONTINUE
1550C initialize /PROCES/
1551 DO 35 I=1,11
1552 IPRON(I,1) = 1
1553 35 CONTINUE
1554
1555C 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
1565C 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
1591C 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
1601C initialize /POPISR/
1602 DO 40 I=1,50
1603 IPOISR(1,2,I) = 0
1604 IPOISR(2,2,I) = 0
1605 40 CONTINUE
1606C 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
1625C 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
1633C switch all hard subprocesses on
1634 MH_pro_on(M,I) = 1
1635C 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
1643C 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
1654C initialize /POFSRC/
1655 IGHEL(1) = -1
1656 IGHEL(2) = -1
1657C 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
1670C 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
1684CDECK ID>, PHO_PARDAT
1685 SUBROUTINE PHO_PARDAT
1686C***********************************************************************
1687C
1688C particle data (based on 1996 PDG naming scheme and data tables)
1689C
1690C***********************************************************************
1691
1692 IMPLICIT NONE
1693
1694 SAVE
1695
1696C input/output channels
1697 INTEGER LI,LO
1698 COMMON /POINOU/ LI,LO
1699C 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
1706C 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
1711C 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)
1724C 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
1730C external functions
1731
1732 integer ipho_pdg2id
1733 double precision pho_pmass
1734
1735C 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
2278C 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
2292C 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
2298C 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
2306C 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
2320C copy secondary particles
2321C (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
2339C 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
2350C 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
2356C 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)
2370C 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
2390C 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
2397C 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
2404C 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
2411C 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)
2420C 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
2435C 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
2443C 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)
2457C 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
2481CDECK ID>, PHO_PRESEL
2482 SUBROUTINE PHO_PRESEL(MODE,IREJ)
2483C**********************************************************************
2484C
2485C user specific function to pre-select events during generation
2486C
2487C input: MODE 5 electron and photon kinematics
2488C 10 process and number of cut Pomerons
2489C 15 partons without construction of strings
2490C 20 partons assigned to strings
2491C 25 after fragmentation, complete final state
2492C
2493C output: IREJ 0 event accepted
2494C 50 event rejected
2495C
2496C**********************************************************************
2497 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2498 SAVE
2499
2500C input/output channels
2501 INTEGER LI,LO
2502 COMMON /POINOU/ LI,LO
2503C 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
2511C 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)
2521C 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
2525C 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)
2529C 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)
2536C 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)
2549C 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
2562CDECK ID>, PHO_FIXCOL
2563 SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
2564C**********************************************************************
2565C
2566C interface to call PHOJET (fixed energy run) with
2567C collider kinematics
2568C
2569C equivalen photon approximation to get photon flux
2570C
2571C input: NEV number of events to generate
2572C THETA azimuthal angle (micro radians)
2573C PHI beam crossing angle
2574C (with respect to x, in degrees)
2575C E1 energy of particle 1 (+z direction, GeV)
2576C E2 energy of particle 2 (-z direction, GeV)
2577C
2578C note: particle types have to be specified before
2579C with PHO_SETPAR
2580C
2581C**********************************************************************
2582 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2583 SAVE
2584
2585 PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
2586
2587C input/output channels
2588 INTEGER LI,LO
2589 COMMON /POINOU/ LI,LO
2590C 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
2597C general process information
2598 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2599 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2600C 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)
2604C 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)
2609C 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)
2614C integration precision for hard cross sections (obsolete)
2615 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2616 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2617C 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
2625C 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)
2642C 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)
2661C 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
2668C 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
2693CDECK ID>, PHO_FIXLAB
2694 SUBROUTINE PHO_FIXLAB(PLAB,NEV)
2695C**********************************************************************
2696C
2697C interface to call PHOJET (fixed energy run) with
2698C LAB kinematics (second particle as target)
2699C
2700C equivalent photon approximation to get photon flux
2701C
2702C input: NEV number of events to generate
2703C PLAB LAB momentum of particle 1
2704C
2705C note: particle types have to be specified before
2706C with PHO_SETPAR
2707C
2708C**********************************************************************
2709 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2710 SAVE
2711
2712C input/output channels
2713 INTEGER LI,LO
2714 COMMON /POINOU/ LI,LO
2715C 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
2722C general process information
2723 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2724 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2725C 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)
2729C 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)
2734C 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)
2739C integration precision for hard cross sections (obsolete)
2740 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2741 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2742C 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
2750C 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
2764C 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)
2787C 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
2815CDECK ID>, PHO_GPHERA
2816 SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
2817C**********************************************************************
2818C
2819C interface to call PHOJET (variable energy run) with
2820C HERA kinematics, photon as particle 2
2821C
2822C equivalent photon approximation to get photon flux
2823C
2824C input: NEVENT number of events to generate
2825C EE1 proton energy (LAB system)
2826C EE2 electron energy (LAB system)
2827C from /POFCUT/:
2828C YMIN2 lower limit of Y
2829C (energy fraction taken by photon from electron)
2830C YMAX2 upper limit of Y
2831C Q2MIN2 lower limit of photon virtuality
2832C Q2MAX2 upper limit of photon virtuality
2833C
2834C**********************************************************************
2835 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2836 SAVE
2837
2838 PARAMETER ( DEPS = 1.D-10,
2839 & PI = 3.14159265359D0 )
2840
2841C input/output channels
2842 INTEGER LI,LO
2843 COMMON /POINOU/ LI,LO
2844C 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
2851C 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)
2856C 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
2867C 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)
2874C 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)
2879C 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
2888C assign particle momenta according to HERA kinematics
2889C proton data
2890 PROM = PHO_PMASS(2212,1)
2891 PROM2 = PROM**2
2892 IDPSRC(1) = 0
2893 IDBSRC(1) = 0
2894C 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)
2900C
2901 Q2MIN = Q2MIN2
2902 Q2MAX = Q2MAX2
2903C
2904 XIMAX = LOG(YMAX2)
2905 XIMIN = LOG(YMIN2)
2906 XIDEL = XIMAX-XIMIN
2907C
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)
2912C
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
2933C
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)
2941C
2942C initialization of PHOJET at upper energy limit
2943C proton momentum
2944 P1(1) = 0.D0
2945 P1(2) = 0.D0
2946 P1(3) = SQRT(EE1**2-PROM2+DEPS)
2947 P1(4) = EE1
2948C photon momentum
2949 EGAM = YMAX2*EE2
2950 P2(1) = 0.D0
2951 P2(2) = 0.D0
2952 P2(3) = -EGAM
2953 P2(4) = EGAM
2954C sum of both photon polarizations
2955 IGHEL(2) = -1
2956C
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)
2962C
2963C 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
2982C 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
3000C 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
3009C
3010
3011C 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
3017C 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
3027C set /POFSRC/
3028 GYY(2) = YY
3029 GQ2(2) = Q2
3030C polar angle
3031 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3032C 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
3036C azimuthal angle
3037 PFPHI(2) = ATAN2(COF,SIF)
3038C 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)
3043C proton momentum
3044 P1(1) = 0.D0
3045 P1(2) = 0.D0
3046 P1(3) = SQRT(EE1**2-PROM2)
3047 P1(4) = EE1
3048C 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)
3053C
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)
3059C 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
3071C user cuts
3072 CALL PHO_PRESEL(5,IREJ)
3073 IF(IREJ.NE.0) GOTO 175
3074C event generation
3075 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3076 IF(IREJ.NE.0) GOTO 150
3077
3078C 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))
3089C histograms
3090 CALL PHO_PHIST(1,HSWGHT(0))
3091 CALL PHO_LHIST(1,HSWGHT(0))
3092 200 CONTINUE
3093C
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)
3103C 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
3121C
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
3132CDECK ID>, PHO_GGEPEM
3133 SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
3134C**********************************************************************
3135C
3136C interface to call PHOJET (variable energy run) for
3137C gamma-gamma collisions on e+e- collider
3138C
3139C fully differential equivalent (improved) photon approximation
3140C to get photon flux
3141C
3142C input: EE1 LAB system energy of electron/positron 1
3143C EE2 LAB system energy of electron/positron 2
3144C NEVENT >0 number of events to generate
3145C -1 initialization
3146C -2 final call (cross section calculation)
3147C from /LEPCUT/:
3148C YMIN1 lower limit of Y1
3149C (energy fraction taken by photon from electron)
3150C YMAX1 upper limit of Y1
3151C Q2MIN1 lower limit of photon virtuality
3152C Q2MAX1 upper limit of photon virtuality
3153C THMIN1 lower limit of scattered electron
3154C THMAX1 upper limit of scattered electron
3155C YMIN2 lower limit of Y2
3156C (energy fraction taken by photon from electron)
3157C YMAX2 upper limit of Y2
3158C Q2MIN2 lower limit of photon virtuality
3159C Q2MAX2 upper limit of photon virtuality
3160C THMIN2 lower limit of scattered electron
3161C THMAX2 upper limit of scattered electron
3162C
3163C output: after final call with NEVENT=-2
3164C EE1 e+ e- cross section (mb)
3165C EE2 gamma-gamma cross section (mb)
3166C
3167C**********************************************************************
3168
3169 IMPLICIT NONE
3170
3171 SAVE
3172
3173 DOUBLE PRECISION EE1,EE2
3174 INTEGER NEVENT
3175
3176C input/output channels
3177 INTEGER LI,LO
3178 COMMON /POINOU/ LI,LO
3179C 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
3186C 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)
3191C 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)
3195C 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
3206C 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)
3213C 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)
3218C 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
3224C external functions
3225 DOUBLE PRECISION DT_RNDM
3226
3227C 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
3244C 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
3256C electron data
3257 ELEM = 0.512D-03
3258 ELEM2 = ELEM**2
3259 AMSRC(1) = ELEM
3260 AMSRC(2) = ELEM
3261C lepton numbers
3262 IDPSRC(1) = 11
3263 IDPSRC(2) = -11
3264 IDBSRC(1) = ipho_pdg2id(11)
3265 IDBSRC(2) = ipho_pdg2id(-11)
3266
3267C 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
3303C 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
3316C 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
3350C 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
3357C 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
3363C 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
3370C initialize gamma-gamma event generator
3371
3372C 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
3378C 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
3384C sum of helicities
3385 IGHEL(1) = -1
3386 IGHEL(2) = -1
3387
3388C set min. energy for interpolation tables
3389 parmdl(19) = min(parmdl(19),ecmin)
3390
3391C 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
3398C 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
3429C 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
3437C 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
3477C 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
3481C 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
3505C 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
3511C 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
3522C 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
3528C 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
3534C 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
3545C 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
3552C 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
3559C beam lepton detector acceptance
3560
3561C 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
3568C 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
3575C beam lepton taggers
3576
3577C anti-tag
3578 IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
3579 IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
3580C tag
3581 IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
3582 IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
3583C single-tag inclusive
3584 IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
3585 & GOTO 175
3586C 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
3601C 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
3624C user cuts
3625 CALL PHO_PRESEL(5,IREJ)
3626 IF(IREJ.NE.0) GOTO 175
3627
3628 WGFX = 1.D0
3629C 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
3640C 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
3650C 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
3660C polar angle
3661 PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
3662 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3663C azimuthal angle
3664 PFPHI(1) = ATAN2(COF1,SIF1)
3665 PFPHI(2) = ATAN2(COF2,SIF2)
3666
3667C 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
3693C external histograms
3694 CALL PHO_PHIST(1,HSWGHT(0))
3695 CALL PHO_LHIST(1,HSWGHT(0))
3696 200 CONTINUE
3697
3698C 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
3724C 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
3775CDECK ID>, PHO_WGEPEM
3776 SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
3777C**********************************************************************
3778C
3779C calculate cross section weights for
3780C fully differential equivalent (improved) photon approximation
3781C and/or
3782C fully differential QPM model with exact one-photon exchange graphs
3783C
3784C (unpolarized lepton beams)
3785C
3786C input: IMODE 0 flux calculation only
3787C 1 flux folded with QPM cross section
3788C /POFSRC/ photon and electron momenta
3789C /POPRCS/ process type
3790C /POCKIN/ kinematics of hard scattering
3791C
3792C output: WGHAPP weight of event according to approximation
3793C WGHQPM weight of event according to one-photon exchange
3794C
3795C**********************************************************************
3796
3797 IMPLICIT NONE
3798
3799 SAVE
3800
3801 DOUBLE PRECISION WGHAPP,WGHQPM
3802 INTEGER IMODE
3803
3804C input/output channels
3805 INTEGER LI,LO
3806 COMMON /POINOU/ LI,LO
3807C 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
3814C 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)
3819C 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)
3823C 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)
3830C general process information
3831 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3832 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3833C 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
3843C 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
3847C 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
3854C 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)
3864C 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
3884C strict pt cutoff after putting partons on mass shell,
3885C 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
3893C cross section of sampled event (approximate treatment)
3894
3895C 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
3910C 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
3915C 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
3924C final state flavors
3925 IPFL1 = ABS(IDHEP(IPOS+3))
3926 IPFL2 = ABS(IDHEP(IPOS+4))
3927 SH = X1*X2*W2
3928C calculate alpha-em
3929 ALPHA1 = pho_alphae(QQAL)
3930C calculate alpha-s
3931 IF(MSPR.LT.14) THEN
3932 ALPHA2 = PHO_ALPHAS(QQAL,3)
3933 ENDIF
3934C 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
3960C 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
3963C full leading-order QPM prediction (Budnev et al.)
3964
3965C 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
4001C 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
4022C 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
4028C flux folded with cross section
4029C polarized, leading order gam gam --> q qbar cross sections
4030
4031 DO 125 I=1,6
4032 SIGQPM(I) = 0.D0
4033 125 CONTINUE
4034C 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
4044C 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
4061C single-resolved photon-hadron interactions
4062C 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
4221C 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
4230CDECK ID>, PHO_GGBLSR
4231 SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
4232 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
4233C***********************************************************************
4234C
4235C interface to call PHOJET (variable energy run) for
4236C gamma-gamma collisions via laser backscattering
4237C
4238C input: EE1 lab. system energy of electron/positron 1
4239C EE2 lab. system energy of electron/positron 2
4240C NEVENT number of events to generate
4241C Pl_lam_1/2 product of electron and photon pol.
4242C X_1/2 standard X parameter
4243C rho ratio of distance to conversion point and
4244C transverse beam size
4245C A ellipticity of electon beam
4246C
4247C (see Ginzburg & Kotkin hep-ph/9905462)
4248C
4249C from /LEPCUT/:
4250C YMIN1 lower limit of Y1
4251C (energy fraction taken by photon from electron)
4252C YMAX1 upper limit of Y1
4253C YMIN2 lower limit of Y2
4254C (energy fraction taken by photon from electron)
4255C YMAX2 upper limit of Y2
4256C
4257C***********************************************************************
4258 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4259 SAVE
4260
4261 PARAMETER ( PI = 3.14159265359D0 )
4262
4263C input/output channels
4264 INTEGER LI,LO
4265 COMMON /POINOU/ LI,LO
4266C 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
4273C 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
4284C 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)
4291C 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)
4296C 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
4325C 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
4356C initialize event generator
4357
4358C photon 1
4359 EGAM = YMAX1*EE1
4360 P1(1) = 0.D0
4361 P1(2) = 0.D0
4362 P1(3) = EGAM
4363 P1(4) = EGAM
4364C 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
4376C 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
4433C 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
4439C 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
4449C 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)
4454C 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
4460C 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
4470C 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)
4475C 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
4492C photon helicities
4493 IGHEL(1) = 1
4494 IGHEL(2) = 1
4495C cut given by user
4496 CALL PHO_PRESEL(5,IREJ)
4497 IF(IREJ.NE.0) GOTO 175
4498C event generation
4499 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4500 IF(IREJ.NE.0) GOTO 150
4501
4502C statistics
4503 AY1 = AY1+Y1
4504 AYS1 = AYS1+Y1*Y1
4505 AY2 = AY2+Y2
4506 AYS2 = AYS2+Y2*Y2
4507C 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)
4520C 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
4542CDECK ID>, pho_samp1d
4543 SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
4544C***********************************************************************
4545C
4546C Monte Carlo sampling from arbitrary 1d distribution
4547C (linear interpolation to improve reproduction of initial function)
4548C
4549C input: Imode -1 initialization
4550C 1 sampling (after initialization)
4551C X_inp(N_dim) array with x values
4552C F_inp(N_dim) array with function values
4553C F_int(N_dim) array with integral
4554C
4555C output: X_out sampled value (Imode=1)
4556C
4557C (R.E. 10/99)
4558C
4559C***********************************************************************
4560 implicit none
4561 save
4562
4563C 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
4571C local variables
4572 integer i
4573 double precision dum,xi,a,b
4574
4575C external functions
4576 double precision DT_RNDM
4577 external DT_RNDM
4578
4579 if(Imode.eq.-1) then
4580
4581C 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
4591C 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
4608C 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
4617CDECK ID>, pho_ExpBessI0
4618 DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
4619C**********************************************************************
4620C
4621C Bessel Function I0 times exponential function from neg. arg.
4622C (defined for pos. arguments only)
4623C
4624C**********************************************************************
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
4645CDECK ID>, PHO_GGBEAM
4646 SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
4647C**********************************************************************
4648C
4649C interface to call PHOJET (variable energy run) for
4650C gamma-gamma collisions via beamstrahlung
4651C
4652C input: EE LAB system energy of electron/positron
4653C YPSI beamstrahlung parameter
4654C SIGX,Y transverse bunch dimensions
4655C SIGZ longitudinal bunch dimension
4656C AEB number of electrons/positrons in a bunch
4657C NEVENT number of events to generate
4658C from /LEPCUT/:
4659C YMIN1 lower limit of Y
4660C (energy fraction taken by photon from electron)
4661C YMAX1 upper cutoff for Y, necessary to avoid
4662C underflows
4663C
4664C**********************************************************************
4665 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4666 SAVE
4667
4668 PARAMETER ( DEPS = 1.D-20,
4669 & PI = 3.14159265359D0 )
4670
4671C input/output channels
4672 INTEGER LI,LO
4673 COMMON /POINOU/ LI,LO
4674C 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
4681C 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
4692C 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)
4699C 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)
4704C 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
4713C
4714 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
4715C 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
4722C 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
4732C 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
4764C photon 1
4765 EGAM = YMAX*EE
4766 P1(1) = 0.D0
4767 P1(2) = 0.D0
4768 P1(3) = EGAM
4769 P1(4) = EGAM
4770C 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
4782C 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
4823C 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
4829C 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
4839C 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)
4844C 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
4850C 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
4860C 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)
4865C 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
4871C
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
4882C photon helicities
4883 IGHEL(1) = 1
4884 IGHEL(2) = 1
4885C cut given by user
4886 CALL PHO_PRESEL(5,IREJ)
4887 IF(IREJ.NE.0) GOTO 175
4888C event generation
4889 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4890 IF(IREJ.NE.0) GOTO 150
4891 GGECML = LOG(GGECM)
4892
4893C statistics
4894 AY1 = AY1+Y1
4895 AYS1 = AYS1+Y1*Y1
4896 AY2 = AY2+Y2
4897 AYS2 = AYS2+Y2*Y2
4898C histograms
4899 CALL PHO_PHIST(1,HSWGHT(0))
4900 CALL PHO_LHIST(1,HSWGHT(0))
4901 200 CONTINUE
4902C
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)
4911C 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
4922C
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
4933CDECK ID>, PHO_GGHIOF
4934 SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
4935C**********************************************************************
4936C
4937C interface to call PHOJET (variable energy run) for
4938C gamma-gamma collisions via heavy ions (form factor approach)
4939C
4940C input: EEN LAB system energy per nucleon
4941C NA atomic number of ion/hadron
4942C NZ charge number of ion/hadron
4943C NEVENT number of events to generate
4944C from /LEPCUT/:
4945C YMIN1,2 lower limit of Y
4946C (energy fraction taken by photon from hadron)
4947C YMAX1,2 upper cutoff for Y, necessary to avoid
4948C underflows
4949C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
4950C Q2MAX1,2 maximum Q**2 of photons (if necessary,
4951C corrected according size of hadron)
4952C
4953C currently implemented approximation similar to:
4954C E.Papageorgiu PhysLettB250(1990)155
4955C
4956C**********************************************************************
4957 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4958 SAVE
4959
4960 PARAMETER ( PI = 3.14159265359D0 )
4961
4962C input/output channels
4963 INTEGER LI,LO
4964 COMMON /POINOU/ LI,LO
4965C 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)
4970C 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
4977C 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
4988C 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)
4995C 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)
5000C 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
5008C
5009 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
5010 & '--------------------------------------'
5011C 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
5017C 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
5023C total hadron / heavy ion energy
5024 EE = EEN*DBLE(NA)
5025 GAMMA = EE/HIMASS
5026C 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
5033C 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
5053C kinematic limitation
5054 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5055 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5056C 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
5081C hadron numbers set to 0
5082 IDPSRC(1) = 0
5083 IDPSRC(2) = 0
5084 IDBSRC(1) = 0
5085 IDBSRC(2) = 0
5086C
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
5134C
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
5156C
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)
5165C
5166C photon 1
5167 EGAM = YMAX1*EE
5168 P1(1) = 0.D0
5169 P1(2) = 0.D0
5170 P1(3) = EGAM
5171 P1(4) = EGAM
5172C 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)
5183C
5184C 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
5207C 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
5215C
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
5231C 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
5250C impact parameter
5251 GAIMP(1) = 1.D0/SQRT(Q2P1)
5252 GAIMP(2) = 1.D0/SQRT(Q2P2)
5253C 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
5259C 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
5270C photon data
5271 GYY(1) = Y1
5272 GQ2(1) = Q2P1
5273 GYY(2) = Y2
5274 GQ2(2) = Q2P2
5275C
5276
5277C 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
5283C 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))
5295C 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)
5300C 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
5306C 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))
5318C 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)
5323C 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
5329C
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)
5340C photon helicities
5341 IGHEL(1) = 1
5342 IGHEL(2) = 1
5343C cut given by user
5344 CALL PHO_PRESEL(5,IREJ)
5345 IF(IREJ.NE.0) GOTO 175
5346C event generation
5347 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5348 IF(IREJ.NE.0) GOTO 150
5349
5350C 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
5367C histograms
5368 CALL PHO_PHIST(1,HSWGHT(0))
5369 CALL PHO_LHIST(1,HSWGHT(0))
5370 200 CONTINUE
5371C
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)
5387C 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
5412C
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
5423CDECK ID>, PHO_GGHIOG
5424 SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
5425C**********************************************************************
5426C
5427C interface to call PHOJET (variable energy run) for
5428C gamma-gamma collisions via heavy ions (geometrical approach)
5429C
5430C
5431C input: EEN LAB system energy per nucleon
5432C NA atomic number of ion/hadron
5433C NZ charge number of ion/hadron
5434C NEVENT number of events to generate
5435C from /LEPCUT/:
5436C YMIN1,2 lower limit of Y
5437C (energy fraction taken by photon from hadron)
5438C YMAX1,2 upper cutoff for Y, necessary to avoid
5439C underflows
5440C
5441C currently implemented approximation similar to:
5442C
5443C
5444C**********************************************************************
5445 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5446 SAVE
5447
5448 PARAMETER ( DEPS = 1.D-20,
5449 & PI = 3.14159265359D0 )
5450
5451C input/output channels
5452 INTEGER LI,LO
5453 COMMON /POINOU/ LI,LO
5454C 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
5461C 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
5472C 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)
5479C 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)
5484C 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
5493C
5494 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
5495 & '---------------------------------------'
5496C 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
5502C total hadron / heavy ion energy
5503 EE = EEN*DBLE(NA)
5504 GAMMA = EE/HIMASS
5505C 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
5512C 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
5532C 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
5544C hadron numbers set to 0
5545 IDPSRC(1) = 0
5546 IDBSRC(1) = 0
5547 IDPSRC(2) = 0
5548 IDBSRC(2) = 0
5549C 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
5603C
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
5626C
5627C initialization
5628C photon 1
5629 EGAM = YMAX*EE
5630 P1(1) = 0.D0
5631 P1(2) = 0.D0
5632 P1(3) = EGAM
5633 P1(4) = EGAM
5634C 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)
5645C
5646C 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
5684C setup kinematics
5685
5686 GYY(1) = Y1
5687 GQ2(1) = 0.D0
5688 GYY(2) = Y2
5689 GQ2(2) = 0.D0
5690C 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
5696C 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
5703C 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)
5708C 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
5714C 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
5721C 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)
5726C 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
5741C 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
5748C photon helicities
5749 IGHEL(1) = 1
5750 IGHEL(2) = 1
5751C cut given by user
5752 CALL PHO_PRESEL(5,IREJ)
5753 IF(IREJ.NE.0) GOTO 175
5754C event generation
5755 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5756 IF(IREJ.NE.0) GOTO 150
5757
5758C 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)
5767C histograms
5768 CALL PHO_PHIST(1,HSWGHT(0))
5769 CALL PHO_LHIST(1,HSWGHT(0))
5770 200 CONTINUE
5771C
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)
5780C 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
5798C
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
5809CDECK ID>, PHO_GGFLCL
5810 DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
5811C*********************************************************************
5812C
5813C semi-classical photon flux (geometrical model)
5814C
5815C*********************************************************************
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
5824CDECK ID>, PHO_GGFLCR
5825 DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
5826C*********************************************************************
5827C
5828C semi-classical photon flux correction due to
5829C overlap in impact parameter space (geometrical model)
5830C
5831C*********************************************************************
5832 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5833 SAVE
5834
5835 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
5836
5837C input/output channels
5838 INTEGER LI,LO
5839 COMMON /POINOU/ LI,LO
5840C 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
6108C integrate first over b1
6109C
6110C Loop incrementing the boundary
6111C
6112 tmin = 0.D0
6113 tmax = 0.25D0
6114 Sum = 0.D0
6115
6116 50 CONTINUE
6117
6118C
6119C Loop for the Gauss integration
6120C
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
6147CDECK ID>, PHO_GGFAUX
6148 DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
6149C*********************************************************************
6150C
6151C auxiliary function for integration over b2,
6152C semi-classical photon flux correction due to
6153C overlap in impact parameter space (geometrical model)
6154C
6155C*********************************************************************
6156 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6157 SAVE
6158
6159 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
6160
6161C input/output channels
6162 INTEGER LI,LO
6163 COMMON /POINOU/ LI,LO
6164C 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/
6431C
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
6461CDECK ID>, PHO_GGFNUC
6462 DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
6463C**********************************************************************
6464C
6465C differential photonnumber for a nucleus (geometrical model)
6466C (without form factor)
6467C
6468C*********************************************************************
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
6481CDECK ID>, PHO_GHHIOF
6482 SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
6483C**********************************************************************
6484C
6485C interface to call PHOJET (variable energy run) for
6486C gamma-hadron collisions in heavy ion collisions
6487C (form factor approach)
6488C
6489C input: EEN LAB system energy per nucleon
6490C NA atomic number of ion/hadron
6491C NZ charge number of ion/hadron
6492C NEVENT number of events to generate
6493C from /LEPCUT/:
6494C YMIN1,2 lower limit of Y
6495C (energy fraction taken by photon from hadron)
6496C YMAX1,2 upper cutoff for Y, necessary to avoid
6497C underflows
6498C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
6499C Q2MAX1,2 maximum Q**2 of photons (if necessary,
6500C corrected according size of hadron)
6501C
6502C**********************************************************************
6503 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6504 SAVE
6505
6506 PARAMETER ( PI = 3.14159265359D0 )
6507
6508C input/output channels
6509 INTEGER LI,LO
6510 COMMON /POINOU/ LI,LO
6511C 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)
6516C 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
6523C 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
6534C 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)
6541C 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
6547C 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)
6557C 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
6561C 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 & '-----------------------------------------'
6573C 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
6581C 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
6587C total hadron / heavy ion energy
6588 EE = EEN*DBLE(NA)
6589 GAMMA = EE/HIMASS
6590C 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
6597C 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
6604C 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
6624C kinematic limitation
6625 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6626 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6627C 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
6656C hadron numbers set to 0
6657 IDPSRC(1) = 0
6658 IDPSRC(2) = 0
6659 IDBSRC(1) = 0
6660 IDBSRC(2) = 0
6661C
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
6697C
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
6719C
6720C 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
6726C 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)
6734C
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
6743C
6744 IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
6745 IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
6746C
6747 FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
6748 & /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
6749C
6750 CALL PHO_PHIST(-1,SIGMAX)
6751 CALL PHO_LHIST(-1,SIGMAX)
6752C
6753C 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
6778C sample y1, y2
6779 150 CONTINUE
6780 ITRY = ITRY+1
6781 175 CONTINUE
6782C
6783C select side of photon emission
6784 IF(DT_RNDM(AY1).LT.FAC12) THEN
6785 ITRW(1) = ITRW(1)+1
6786C 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
6796C 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
6806C impact parameter
6807 GAIMP(1) = 1.D0/SQRT(Q2P1)
6808C 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
6812C photon data
6813 GYY(1) = Y1
6814 GQ2(1) = Q2P1
6815
6816C
6817C 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
6823C 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))
6835C 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
6841C 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)
6846C 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
6852C
6853 ELSE
6854C
6855 ITRW(2) = ITRW(2)+1
6856C 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
6866C 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
6876C impact parameter
6877 GAIMP(2) = 1.D0/SQRT(Q2P2)
6878C 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
6882C photon data
6883 GYY(2) = Y2
6884 GQ2(2) = Q2P2
6885
6886C
6887C 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
6893C 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
6899C 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))
6911C scattering hadron
6912 P2(1) = 0.D0
6913 P2(2) = 0.D0
6914 P2(3) = SQRT(EEN**2-AMP2)
6915 P2(4) = EEN
6916C 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
6923C 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
6929C
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)
6941C photon helicities
6942 IGHEL(1) = 1
6943 IGHEL(2) = 1
6944C user cuts
6945 IF(IREJ.NE.0) GOTO 175
6946C event generation
6947 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
6948 IF(IREJ.NE.0) GOTO 150
6949C 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
6965C 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
6975C
6976C 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
7000C histograms
7001 CALL PHO_PHIST(1,HSWGHT(0))
7002 CALL PHO_LHIST(1,HSWGHT(0))
7003 200 CONTINUE
7004C
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)
7024C 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
7050C
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
7061CDECK ID>, PHO_GHHIAS
7062 SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
7063C**********************************************************************
7064C
7065C interface to call PHOJET (variable energy run) for
7066C gamma-hadron collisions in heavy ion - hadron
7067C collisions (form factor approach)
7068C
7069C input: EEP LAB system energy of proton (GeV)
7070C EEN LAB system energy per nucleon (GeV)
7071C NA atomic number of ion/hadron
7072C NZ charge number of ion/hadron
7073C NEVENT number of events to generate
7074C from /LEPCUT/:
7075C YMIN2 lower limit of Y
7076C (energy fraction taken by photon from hadron)
7077C YMAX2 upper cutoff for Y, necessary to avoid
7078C underflows
7079C Q2MIN2 minimum Q**2 of photons (should be set to 0)
7080C Q2MAX2 maximum Q**2 of photons (if necessary,
7081C corrected according size of hadron)
7082C
7083C**********************************************************************
7084 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7085 SAVE
7086
7087 PARAMETER ( PI = 3.14159265359D0 )
7088
7089C input/output channels
7090 INTEGER LI,LO
7091 COMMON /POINOU/ LI,LO
7092C 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)
7097C 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
7104C 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
7115C 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)
7122C 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
7128C 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)
7138C 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
7142C 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 & '-----------------------------------------'
7153C 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
7161C 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
7165C total hadron / heavy ion energy
7166 EE = EEN*DBLE(NA)
7167 GAMMA = EE/HIMASS
7168C setup /POFSRC/
7169 GAMSRC(2) = GAMMA
7170 RADSRC(2) = HIRADI
7171 AMSRC(2) = HIMASS
7172C 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
7183C kinematic limitation
7184 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7185C 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
7203C hadron numbers set to 0
7204 IDPSRC(1) = 0
7205 IDPSRC(2) = 0
7206 IDBSRC(1) = 0
7207 IDBSRC(2) = 0
7208C
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
7227C
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
7246C
7247C hadron
7248 P1(1) = 0.D0
7249 P1(2) = 0.D0
7250 P1(3) = -SQRT(EEP**2-AMP2)
7251 P1(4) = EEP
7252C 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)
7261C
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
7266C
7267 CALL PHO_PHIST(-1,SIGMAX)
7268 CALL PHO_LHIST(-1,SIGMAX)
7269C
7270C 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
7287C sample photon flux
7288 150 CONTINUE
7289 ITRY = ITRY+1
7290 175 CONTINUE
7291C
7292 ITRW = ITRW+1
7293C 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
7303C 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
7313C impact parameter
7314 GAIMP(2) = 1.D0/SQRT(Q2P2)
7315C 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
7319C photon data
7320 GYY(2) = Y2
7321 GQ2(2) = Q2P2
7322
7323C
7324C 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
7330C 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
7336C 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))
7348C 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
7354C 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
7360C
7361C 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
7367C
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)
7378C photon helicities
7379 IGHEL(2) = 1
7380C user cuts
7381 CALL PHO_PRESEL(5,IREJ)
7382 IF(IREJ.NE.0) GOTO 175
7383C event generation
7384 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
7385 IF(IREJ.NE.0) GOTO 150
7386C 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
7402C 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
7412C
7413C 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)
7425C histograms
7426 CALL PHO_PHIST(1,HSWGHT(0))
7427 CALL PHO_LHIST(1,HSWGHT(0))
7428 200 CONTINUE
7429C
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)
7441C 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
7459C
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
7471CDECK ID>, PHO_FITPAR
7472 SUBROUTINE PHO_FITPAR(IOUTP)
7473C**********************************************************************
7474C
7475C read input parameters according to PDFs
7476C
7477C**********************************************************************
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
7485C input/output channels
7486 INTEGER LI,LO
7487 COMMON /POINOU/ LI,LO
7488C 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
7495C 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)
7500C 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)
7504C 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
7510C 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
7517C 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
7530C 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
7540C 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
7550C 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
7560C 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
7570C 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
7580C 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
7590C 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
7600C 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
7610C 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
7620C 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
7630C 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
7640C 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
7650C 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
7660C 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
7670C 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
7680C 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
7690C 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
7700C 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
7710C 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
7720C 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
7730C 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
7740C 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
7762C 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)
7767C 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
7779C 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
7793C *** Commented by Chiara
7794C WRITE(LO,'(/1X,A)')
7795C & '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
7834C *** Commented by Chiara
7835C WRITE(LO,'(/1X,A)')
7836C & 'PHO_FITPAR: parameter set not found in internal table'
7837 ENDIF
7838
7839 1200 CONTINUE
7840
7841C 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
7888C 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
7900C 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
8015C output of parameter set
8016C *** Commented by Chiara
8017C IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
8018C WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
8019C & ' -------------------------'
8020C WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8021C & ' ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
8022C & B0POM
8023C WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8024C & ' ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
8025C & B0REG
8026C WRITE(LO,'(4(A,F7.3))')
8027C & ' GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
8028C WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
8029C WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
8030C WRITE(LO,'(A,F8.3)') ' B0HAR:',B0HAR
8031C WRITE(LO,'(A,F8.3)') ' AKFAC:',AKFAC
8032C WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
8033C WRITE(LO,'(A,3F8.3)') ' RMASS:',RMASS,VAR
8034C ENDIF
8035
8036 CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
8037
8038 END
8039
8040CDECK ID>, PHO_BORNCS
8041 SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
8042C*********************************************************************
8043C
8044C calculation of Born graph cross sections and slopes
8045C
8046C input: IP particle combination
8047C IFHARD -1 calculate hard Born graph cross section
8048C 0 take hard Born graph cross section
8049C from interpolation table if available
8050C 1 assume that correct hard cross
8051C sections are already stored in /POSBRN/
8052C XM1,XM2,XM3,XM4 masses of external lines
8053C /GLOCMS/ energy and PT cut-off
8054C /POPREG/ soft and hard parameters
8055C /POSBRN/ input cross sections
8056C /POZBRN/ scaled input values
8057C IFHARD 0 calculate hard input cross sections
8058C 1 assume hard input cross sections exist
8059C
8060C output: ZPOM scaled pomeron cross section
8061C ZIGR scaled reggeon cross section
8062C ZIGHR scaled hard resolved cross section
8063C ZIGHD scaled hard direct cross section
8064C ZIGT1 scaled triple-Pomeron cross section
8065C ZIGT2 scaled triple-Pomeron cross section
8066C ZIGL scaled loop-Pomeron cross section
8067C
8068C*********************************************************************
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
8081C input/output channels
8082 INTEGER LI,LO
8083 COMMON /POINOU/ LI,LO
8084C 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)
8088C 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
8095C 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)
8100C 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)
8105C 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)
8116C 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)
8130C 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)
8137C 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)
8145C 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
8152C 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
8155C 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
8162C 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
8165C 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
8181C 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
8184C scales
8185 CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
8186C
8187C 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
8190C 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
8197C 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
8201C
8202C 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
8224C 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
8238C 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
8244C 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
8254C 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
8271C 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
8274C pomeron signature
8275 SP=SS*DCMPLX(0.D0,-1.D0)
8276C reggeon signature
8277 SR=SS*DCMPLX(0.D0,1.D0)
8278 ELSE
8279 SP=SS
8280 SR=SS
8281 ENDIF
8282C coupling constants (mb**1/2)
8283C 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
8340C input slope parameters (GeV**-2)
8341 BPOM1 = B0POM1*SCALB1
8342 BPOM2 = B0POM2*SCALB2
8343 BREG1 = B0REG1*SCALB1
8344 BREG2 = B0REG2*SCALB2
8345C 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
8363C input cross section pomeron
8364 SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
8365 SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
8366C save value to calculate soft pt distribution
8367 SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
8368
8369C higher order graphs
8370 VIRT1 = PVIRTP(1)
8371 VIRT2 = PVIRTP(2)
8372C 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
8381C 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)
8386C
8387C input cross section high mass diffraction particle 1
8388C 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
8397C 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)
8402C 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
8411C 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)
8416C
8417C input cross section high mass diffraction particle 2
8418C 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
8427C 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)
8432C 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
8441C 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)
8446C
8447C input cross section for loop-pomeron
8448C 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)
8465C 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)
8482C 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)
8499C 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)
8516C
8517C input cross section for YY-iterated triple-pomeron
8518C .....
8519C
8520C 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
8554C
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
8564C
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
8574C
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
8589C
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
8608CDECK ID>, PHO_SCALES
8609 SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
8610C**********************************************************************
8611C
8612C calculation of scale factors
8613C (mass dependent couplings and slopes)
8614C
8615C input: XM1..XM4 external masses
8616C
8617C output: SCG1,SCG2 scales of coupling constants
8618C SCB1,SCB2 scales of coupling slope parameter
8619C
8620C*********************************************************************
8621 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8622 SAVE
8623
8624 PARAMETER ( EPS = 1.D-3 )
8625
8626C input/output channels
8627 INTEGER LI,LO
8628 COMMON /POINOU/ LI,LO
8629C 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
8636C 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
8643C 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
8646C 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
8653C 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
8659C 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
8681C
8682C 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
8687C 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
8691C 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
8709C 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
8718CDECK ID>, PHO_EIKON
8719 SUBROUTINE PHO_EIKON(IP,IFHARD,B)
8720C*********************************************************************
8721C
8722C calculation of unitarized amplitudes
8723C
8724C input: IP particle combination
8725C IFHARD -1 ignore previously calculated Born
8726C cross sections
8727C 0 calculate hard Born cross sections or
8728C take them from interpolation table
8729C (if available)
8730C 1 take hard cross sections from /POSBRN/
8731C B impact parameter (mb**(1/2))
8732C /POSBRN/ input cross sections
8733C /GLOCMS/ cm energy
8734C /POPREG/ soft and hard parameters
8735C
8736C output: /POINT4/
8737C AMPEL purely elastic amplitude
8738C AMPVM quasi-elastically vectormeson prod.
8739C AMLMSD(2) amplitudes of low mass sing. diffr.
8740C AMHMSD(2) amplitudes of high mass sing. diffr.
8741C AMLMDD amplitude of low mass double diffr.
8742C AMHMDD amplitude of high mass double diffr.
8743C
8744C*********************************************************************
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
8758C input/output channels
8759 INTEGER LI,LO
8760 COMMON /POINOU/ LI,LO
8761C 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
8768C 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)
8773C 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
8786C 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)
8793C 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)
8801C 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)
8807C 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)
8811C 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
8818C 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
8825C 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
8828C 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)
8833C 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
8859C calculation of scaled cross sections and slopes
8860
8861C 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
8864C 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
8879C 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
8891C 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
8903C 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
8945C 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
8987C 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
9029C 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
9071C 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
9130C different models
9131
9132 IF(ISWMDL(1).LT.3) THEN
9133C pomeron
9134 AUXP = ZXP(1,1)*EXP(-B24/BXP(1,1))
9135C reggeon
9136 AUXR = ZXR(1,1)*EXP(-B24/BXR(1,1))
9137C hard resolved processes
9138 AUXH = ZXH(1,1)*EXP(-B24/BXH(1,1))
9139C hard direct processes
9140 AUXD = ZXD(1,1)*EXP(-B24/BXD(1,1))
9141C 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))
9144C 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))
9147C 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
9180C 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
9192CDECK ID>, PHO_DSIGDT
9193 SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
9194C*********************************************************************
9195C
9196C calculation of unitarized amplitude
9197C and differential cross section
9198C
9199C input: EE cm energy (GeV)
9200C XTA(1,*) t values (GeV**2)
9201C NFILL entries in t table
9202C
9203C output: XTA(2,*) DSIG/DT g p --> g h/V (mub/GeV**2)
9204C XTA(3,*) DSIG/DT g p --> rho0 h/V
9205C XTA(4,*) DSIG/DT g p --> omega0 h/V
9206C XTA(5,*) DSIG/DT g p --> phi h/V
9207C XTA(6,*) DSIG/DT g p --> pi+ pi- h/V (continuum)
9208C
9209C*********************************************************************
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
9220C input/output channels
9221 INTEGER LI,LO
9222 COMMON /POINOU/ LI,LO
9223C 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)
9227C integration precision for hard cross sections (obsolete)
9228 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9229 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9230C 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
9237C 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)
9241C 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
9264C
9265 DO 100 K=1,NFILL
9266 DO 150 L=1,5
9267 XT(L,K)=CZERO
9268 150 CONTINUE
9269 100 CONTINUE
9270C
9271C impact parameter integration
9272C 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
9296C
9297 DO 200 I=1,NGAUSO
9298 WG=WGHT(I)*XPNT(I)
9299C 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)
9310C
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
9319C
9320C 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
9346CDECK ID>, PHO_XSECT
9347 SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
9348C*********************************************************************
9349C
9350C calculation of physical cross sections
9351C
9352C input: IP particle combination
9353C IFHARD -1 reset Born graph cross section tables
9354C 0 calculate hard cross sections or take them
9355C from interpolation table (if available)
9356C 1 assume that hard cross sections are already
9357C calculated and stored in /POSBRN/
9358C EE cms energy (GeV)
9359C
9360C output: /POSBRN/ input cross sections
9361C /POZBRN/ scaled input cross values
9362C /POCSEC/ physical cross sections and slopes
9363C
9364C slopes in GeV**-2, cross sections in mb
9365C
9366C*********************************************************************
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
9374C input/output channels
9375 INTEGER LI,LO
9376 COMMON /POINOU/ LI,LO
9377C 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)
9381C 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
9388C integration precision for hard cross sections (obsolete)
9389 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9390 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9391C 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)
9396C 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)
9403C 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
9416C 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
9423C 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
9442C impact parameter integration
9443C 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
9475C 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
9533C 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
9543C 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
9556C user-forced change of diffractive cross section
9557
9558 IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
9559
9560C 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
9573C 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
9581C 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
9590C 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
9601C 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
9611C 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
9625C 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
9631C 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
9645C 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
9707CDECK ID>, PHO_IMPAMP
9708 SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
9709C*********************************************************************
9710C
9711C calculation of physical impact parameter amplitude
9712C
9713C input: EE cm energy (GeV)
9714C BMIN lower bound in B
9715C BMAX upper bound in B
9716C NSTEP number of values (linear)
9717C
9718C output: values written to output unit
9719C
9720C*********************************************************************
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
9728C input/output channels
9729 INTEGER LI,LO
9730 COMMON /POINOU/ LI,LO
9731C 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
9738C 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)
9743C 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)
9747C 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)
9755C
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 & '-------------------------------------------------------------'
9760C
9761 BB = BMIN
9762 DO 100 I=1,NSTEP
9763C 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
9777CDECK ID>, PHO_PRBDIS
9778 SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
9779C*********************************************************************
9780C
9781C calculation of multi interactions probabilities
9782C
9783C input: IP particle combination to scatter
9784C ECM CMS energy
9785C IE index for weight storing
9786C /PROBAB/
9787C IMAX max. number of soft pomeron interactions
9788C KMAX max. number of hard pomeron interactions
9789C
9790C output: /PROBAB/
9791C PROB field of probabilities
9792C
9793C*********************************************************************
9794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9795 SAVE
9796
9797 PARAMETER ( EPS=1.D-10 )
9798
9799C input/output channels
9800 INTEGER LI,LO
9801 COMMON /POINOU/ LI,LO
9802C 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
9809C 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
9816C 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
9819C 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)
9826C 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
9829C 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)
9835C 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
9848C 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
9856C 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
9862C 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
9865C 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)
9869C integration precision for hard cross sections (obsolete)
9870 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9871 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9872C 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)
9877C 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
9890C 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
9897C 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
9923C 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
9972C 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
10028C
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)
10033C
10034 ENDIF
10035C
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
10045C
10046C main cross section loop
10047C**********************************************************
10048 DO 5000 IB=1,NGAUSO
10049 B24=XPNT(IB)**2/4.D0
10050 FAC = XPNT(IB)*WGHT(IB)
10051C
10052 IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
10053C
10054C 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
10074C
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
10090C 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
10112C 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)
10119C 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
10131C
10132C**********************************************************
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
10140C 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
10152C 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
10171C 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))
10175C
10176C 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
10216C
10217 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
10218 & 'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
10219C 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
10227C 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
10246C
10247C 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
10251C
10252 SIGTAB(IP,74,IE) = AVERII
10253 SIGTAB(IP,75,IE) = AVERK
10254 SIGTAB(IP,76,IE) = AVERJ
10255C
10256 SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
10257 SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
10258C
10259 IF(IDEB(55).GE.1) THEN
10260
10261C 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
10285C 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
10305CDECK ID>, PHO_SAMPRO
10306 SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
10307C***********************************************************************
10308C
10309C routine to sample kind of process
10310C
10311C input: IP particle combination
10312C IFP1/2 PDG number of particle 1/2
10313C ECM c.m. energy (GeV)
10314C PVIR1/2 virtuality of particle 1/2 (GeV**2, positive)
10315C SPROB suppression factor for processes 1-7
10316C due to rapidity gap survival probability
10317C IPROC mode
10318C -2 output of statistics
10319C -1 initialization
10320C 0 sampling of process
10321C
10322C output: IPROC kind of interaction process:
10323C 1 non-diffractive resolved process
10324C 2 elastic scattering
10325C 3 quasi-elastic rho/omega/phi production
10326C 4 central diffraction
10327C 5 single diffraction according to IDIFF1
10328C 6 single diffraction according to IDIFF2
10329C 7 double diffraction
10330C 8 single-resolved / direct processes
10331C
10332C***********************************************************************
10333
10334 IMPLICIT NONE
10335
10336 SAVE
10337
10338 INTEGER IP,IFP1,IFP2,IPROC
10339 DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
10340
10341C input/output channels
10342 INTEGER LI,LO
10343 COMMON /POINOU/ LI,LO
10344C 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
10351C 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
10364C 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)
10369C general process information
10370 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10371 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10372C 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
10392C interpolate cross sections
10393 CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
10394
10395C 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
10403C 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
10458C 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
10475C 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
10480C 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
10491C 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
10500C *** Commented by Chiara
10501C WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
10502C & 'PHO_SAMPRO: internal process statistics ',
10503C & '(IP,<Ecm>)',K,ECMSUM(K),
10504C & '---------------------------------------'
10505C WRITE(LO,'(8X,A)')
10506C & ' process sampled cross section'
10507C IF(ISWMDL(2).GE.1) THEN
10508C WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
10509C & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10510C & ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
10511C & ' elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
10512C & 'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
10513C & ' double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
10514C & ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
10515C & ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
10516C & ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
10517C & ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
10518C ELSE
10519C WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
10520C & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10521C & ' double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
10522C & ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
10523C ENDIF
10524 ENDIF
10525 ENDIF
10526 270 CONTINUE
10527 ENDIF
10528
10529 END
10530
10531CDECK ID>, PHO_SAMPRB
10532 SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
10533C********************************************************************
10534C
10535C routine to sample number of cut graphs of different kind
10536C
10537C input: IP scattering particle combination
10538C ECMI CMS energy
10539C IP -1 initialization
10540C -2 output of statistics
10541C others sampling of cuts
10542C
10543C output: ISAM number of soft Pomerons cut
10544C JSAM number of soft Reggeons cut
10545C KSAM number of hard Pomerons cut
10546C
10547C PHO_PRBDIS has to be called before
10548C
10549C********************************************************************
10550 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10551 SAVE
10552
10553C input/output channels
10554 INTEGER LI,LO
10555 COMMON /POINOU/ LI,LO
10556C 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
10563C 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)
10568C general process information
10569 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10570 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10571C 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)
10576C 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
10579C 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
10587C 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)
10591C 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
10604C 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
10613C 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
10624C 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
10628C reggeon allowed
10629 ISAM = 0
10630 JSAM = 1
10631 KSAM = 0
10632 AVERB(3,IP) = AVERB(3,IP)+1.D0
10633 ELSE
10634C 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
10643C 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
10665C reggeon probability
10666 PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
10667C calculate soft suppression factor
10668 IF(IP.EQ.1) FSUPP = PARMDL(35)**2
10669 & /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
10670C
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
10696C 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
10704C 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
10711C limitation given by field dimensions
10712 IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
10713
10714 IF(IP.EQ.1) THEN
10715
10716C 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
10723C 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
10743C 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)
10767C 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)
10776C
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
10779C
10780C 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
10792C
10793C write out statistics
10794 ELSE IF(IP.EQ.-2) THEN
10795C *** Commented by Chiara
10796C WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
10797C & '----------------------------------'
10798 DO 70 I=1,4
10799 IF(AVERB(0,I).LT.2.D0) GOTO 75
10800C WRITE(LO,'(1X,A,I3,1P,2E13.3)')
10801C & 'statistics for IP,<Ecm_1>,<Ecm_2>',I,
10802C & ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
10803C WRITE(LO,'(5X,A)')
10804C & 'average number of s-pom,h-pom,reg cuts (bare)'
10805C WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
10806C & (AVERB(K,I)/AVERB(0,I),K=1,3)
10807C WRITE(LO,'(5X,A)')
10808C & 'average (with energy/virtuality corrections)'
10809C WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
10810C & (AVERC(K,I)/AVERC(0,I),K=1,3)
10811
10812 75 CONTINUE
10813 70 CONTINUE
10814 RETURN
10815 ENDIF
10816 END
10817
10818CDECK ID>, PHO_TRIREG
10819 SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
10820 & SIGTR,BTR)
10821C**********************************************************************
10822C
10823C calculation of triple-Pomeron total cross section
10824C according to Gribov's Regge theory
10825C
10826C input: S squared cms energy
10827C GA coupling constant to diffractive line
10828C AA slope related to GA (GeV**-2)
10829C GB coupling constant to elastic line
10830C BB slope related to GB (GeV**-2)
10831C DELTA effective pomeron delta (intercept-1)
10832C ALPHAP slope of pomeron trajectory (GeV**-2)
10833C GPPP triple-Pomeron coupling
10834C BPPP slope related to B0PPP (GeV**-2)
10835C VIR2A virtuality of particle a (GeV**2)
10836C note: units of all coupling constants are mb**1/2
10837C
10838C output: SIGTR total triple-Pomeron cross section
10839C BTR effective triple-Pomeron slope
10840C (differs from diffractive slope!)
10841C
10842C uses E_i (Exponential-Integral function)
10843C
10844C**********************************************************************
10845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10846 SAVE
10847
10848 PARAMETER (EPS =0.0001D0)
10849
10850C input/output channels
10851 INTEGER LI,LO
10852 COMMON /POINOU/ LI,LO
10853C 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
10860C 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
10865C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10866 SIGU = 2.5
10867C integration cut-off Sigma_L (min. squared mass of diff. blob)
10868 SIGL = 5.+VIR2A
10869C 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
10873C
10874 IF(S.LT.5.D0) THEN
10875 SIGTR = 0.D0
10876 BTR = BPPP+BB
10877 RETURN
10878 ENDIF
10879C change units of ALPHAP to mb
10880 ALSCA = ALPHAP*GEV2MB
10881C
10882C 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)
10887C
10888 SIGTR=PART1*(PART2-PART3)
10889C
10890C 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
10897C
10898 IF(SIGTR.LT.EPS) SIGTR = 0.D0
10899 IF(BTR.LT.BB) BTR = BB
10900C
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
10905CDECK ID>, PHO_LOOREG
10906 SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
10907 & VIR2A,VIR2B,SIGLO,BLO)
10908C**********************************************************************
10909C
10910C calculation of loop-Pomeron total cross section
10911C according to Gribov's Regge theory
10912C
10913C input: S squared cms energy
10914C GA coupling constant to diffractive line
10915C AA slope related to GA (GeV**-2)
10916C GB coupling constant to elastic line
10917C BB slope related to GB (GeV**-2)
10918C DELTA effective pomeron delta (intercept-1)
10919C ALPHAP slope of pomeron trajectory (GeV**-2)
10920C GPPP triple-Pomeron coupling
10921C BPPP slope related to B0PPP (GeV**-2)
10922C VIR2A virtuality of particle a (GeV**2)
10923C VIR2B virtuality of particle b (GeV**2)
10924C note: units of all coupling constants are mb**1/2
10925C
10926C output: SIGLO total loop-Pomeron cross section
10927C BLO effective loop-Pomeron slope
10928C (differs from double diffractive slope!)
10929C
10930C uses E_i (Exponential-Integral function)
10931C
10932C**********************************************************************
10933 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10934 SAVE
10935
10936 PARAMETER (EPS =0.0001D0)
10937
10938C input/output channels
10939 INTEGER LI,LO
10940 COMMON /POINOU/ LI,LO
10941C 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
10948C 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
10953C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10954 SIGU = 2.5
10955C integration cut-off Sigma_L (min. squared mass of diff. blob)
10956 SIGL = 5.+VIR2A+VIR2B
10957C 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
10961C
10962 IF(S.LT.5.D0) THEN
10963 SIGLO = 0.D0
10964 BLO = 2.D0*BPPP
10965 RETURN
10966 ENDIF
10967
10968C
10969C change units of ALPHAP to mb
10970 ALSCA = ALPHAP*GEV2MB
10971C
10972C 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 & )
10981C
10982C 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
10988C
10989 IF(SIGLO.LT.EPS) SIGLO = 0.D0
10990 IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
10991C
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
10996CDECK ID>, PHO_TRXPOM
10997 SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
10998 & GPPP,BPPP,SIGDP,BDP)
10999C**********************************************************************
11000C
11001C calculation of total cross section of two tripe-Pomeron
11002C graphs in X configuration according to Gribov's Reggeon field
11003C theory
11004C
11005C input: S squared cms energy
11006C GA coupling constant to elastic line 1
11007C AA slope related to GA (GeV**-2)
11008C GB coupling constant to elastic line 2
11009C BB slope related to GB (GeV**-2)
11010C DELTA effective pomeron delta (intercept-1)
11011C ALPHAP slope of pomeron trajectory (GeV**-2)
11012C BPPP triple-Pomeron coupling
11013C BTR slope related to B0PPP (GeV**-2)
11014C note: units of all coupling constants are mb**1/2
11015C
11016C output: SIGDP total cross section for double-Pomeron
11017C scattering
11018C BDP effective double-Pomeron slope
11019C
11020C**********************************************************************
11021 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11022 SAVE
11023
11024 PARAMETER (EPS =0.0001D0)
11025
11026C input/output channels
11027 INTEGER LI,LO
11028 COMMON /POINOU/ LI,LO
11029C 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
11036C 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)
11041C 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
11048C lower integration cut-off Sigma_L
11049 SIGL = PARMDL(71)**2
11050C 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
11054C integration precision
11055 NGAUS1=16
11056C
11057C 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
11061C
11062 IF(SIGU.LE.SIGL) THEN
11063 SIGDP = 0.D0
11064 BDP = AA+BB
11065 RETURN
11066 ENDIF
11067C
11068C cross section
11069C
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)
11085C 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
11090C
11091C slope
11092 BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
11093C
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
11098CDECK ID>, PHO_CHAN2A
11099 SUBROUTINE PHO_CHAN2A(BB)
11100C***********************************************************************
11101C
11102C simple two channel model to realize low mass diffraction
11103C (version A, iteration of triple- and loop-Pomeron)
11104C
11105C input: BB impact parameter (mb**1/2)
11106C
11107C output: /POINT4/
11108C AMPEL elastic amplitude
11109C AMPVM(4,4) q-elastic VM production
11110C AMLMSD(2) low mass single diffraction amplitude
11111C AMHMSD(2) high mass single diffraction amplitude
11112C AMLMDD low mass double diffraction amplitude
11113C AMHMDD high mass double diffraction amplitude
11114C AMPDP(4) central diffraction amplitude
11115C
11116C***********************************************************************
11117 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11118 SAVE
11119
11120 PARAMETER (DEPS = 1.D-5,
11121 & EIGHT = 8.D0)
11122
11123C input/output channels
11124 INTEGER LI,LO
11125 COMMON /POINOU/ LI,LO
11126C 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
11133C 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)
11138C 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)
11142C 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)
11147C 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)
11159C 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
11166C 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
11169C 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
11174C 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
11180C 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
11294C VDM factors --> amplitudes
11295C 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
11306C 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
11346C 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
11368C 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
11387CDECK ID>, PHO_EVENT
11388 SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
11389C********************************************************************
11390C
11391C main subroutine to manage simulation processes
11392C
11393C input: NEV -1 initialization
11394C 1 generation of events
11395C 2 generation of events without rejection
11396C due to energy dependent cross section
11397C 3 generation of events without rejection
11398C using initialization energy
11399C -2 output of event generation statistics
11400C P1(4) momentum of particle 1 (internal TARGET)
11401C P2(4) momentum of particle 2 (internal PROJECTILE)
11402C FAC used for initialization:
11403C contains cross section the events corresponds to
11404C during generation: current cross section
11405C
11406C output: IREJ 0: event accepted
11407C 1: event rejected
11408C
11409C********************************************************************
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
11417C input/output channels
11418 INTEGER LI,LO
11419 COMMON /POINOU/ LI,LO
11420C 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
11427C 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)
11432C general process information
11433 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11434 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11435C internal rejection counters
11436 INTEGER NMXJ
11437 PARAMETER (NMXJ=60)
11438 CHARACTER*10 REJTIT
11439 INTEGER IFAIL
11440 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11441C 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)
11448C 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)
11452C 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
11465C 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)
11470C 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)
11475C 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)
11486C 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
11497C 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)
11504C amplitude parameters
11505 CALL PHO_FITPAR(1)
11506
11507 CALL PHO_REJSTA(-1)
11508C 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
11515C 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
11549C
11550C -------------- begin event generation ---------------
11551C
11552 IPAMDL(13) = 0
11553 IF(NEV.EQ.3) IPAMDL(13) = 1
11554 KEVENT = KEVENT+1
11555C 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)
11562C 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
11591C 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
11601C 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)
11608C sample number of cut graphs according to IPROCE and
11609C generate parton configurations+strings
11610 CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
11611C 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
11621C 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
11640C fragmentation of strings
11641
11642C FSR and string fragmentation is done separately by DPMJET routines
11643C CALL PHO_STRFRA(IREJ)
11644
11645C 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
11655C 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
11660C event now completely processed and accepted
11661C 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
11677C 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
11691C
11692C 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
11715C 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
11721C ---------------- 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
11731C 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
11775C *** commented by Chiara
11776C IF(ISWMDL(14).GT.0) THEN
11777C WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
11778C & ISWMDL(14)
11779C WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
11780C WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
11781C WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
11782C WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
11783C WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
11784C 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)
11792C 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
11821CDECK ID>, PHO_PARTON
11822 SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
11823C********************************************************************
11824C
11825C calculation of complete parton configuration
11826C
11827C input: IPROC process ID 1 nondiffractive
11828C 2 elastic
11829C 3 quasi-ela. rho,omega,phi prod.
11830C 4 double Pomeron
11831C 5 single diff 1
11832C 6 single diff 2
11833C 7 double diff diss.
11834C 8 single-resolved / direct photon
11835C JM1,2 index of mother particles in /POEVT1/
11836C
11837C
11838C output: complete parton configuration in /POEVT1/
11839C IREJ 1 failure
11840C 0 success
11841C 50 rejection due to user cutoffs
11842C
11843C********************************************************************
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
11851C input/output channels
11852 INTEGER LI,LO
11853 COMMON /POINOU/ LI,LO
11854C 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
11861C 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)
11866C 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
11872C general process information
11873 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11874 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11875C 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)
11879C 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
11892C 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)
11897C 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
11905C 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
11919C-------------------------------------------------------------------
11920C nondiffractive resolved processes
11921
11922 IF(IPROC.EQ.1) THEN
11923C sample number of interactions
11924 555 CONTINUE
11925 IINT = 0
11926 IP = 1
11927C 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
11935C 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
11944C
11945C resolved soft processes: pomeron and reggeon
11946 MSPOM = IINT
11947 MSREG = JINT
11948C resolved hard process: hard pomeron
11949 MHPOM = KINT
11950C resolved absorptive corrections
11951 MPTRI = 0
11952 MPLOO = 0
11953C 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))
11958C ----------------------------
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
11985C ----------------------------
11986
11987C 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
12026C 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
12031C 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
12050C statistics
12051 ISPA = ISPA+KSPOM
12052 IHPA = IHPA+KHPOM
12053 ISRA = ISRA+KSREG
12054 ISTA = ISTA+KSTRG
12055 ISLA = ISLA+KSLOO
12056
12057C-------------------------------------------------------------------
12058C 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
12064C 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
12071C 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
12082C 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
12086C 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
12094C---------------------------------------------------------------------
12095C 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)
12107C
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
12117C 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
12122C 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
12139C-----------------------------------------------------------------------
12140C 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
12158C 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
12187C 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
12194C 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
12205C 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
12209C 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
12214C 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
12234C-----------------------------------------------------------------------
12235C 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
12266C 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
12271C 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
12291C-----------------------------------------------------------------------
12292C 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
12324C-----------------------------------------------------------------------
12325C 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)
12329C IF(IDEB(3).GE.0) THEN
12330C *** Commented by Chiara
12331C WRITE(LO,'(/1X,A,/1X,A)')
12332C & 'PHO_PARTON: internal statistics on parton configurations',
12333C & '--------------------------------------------------------'
12334C WRITE(LO,'(5X,A)') 'process sampled accepted'
12335C WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12336C WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12337C WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12338C WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12339C WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12340C WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12341C WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12342C WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12343C WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12344C WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12345C 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
12361CDECK ID>, PHO_MCINI
12362 SUBROUTINE PHO_MCINI
12363C********************************************************************
12364C
12365C initialization of MC event generation
12366C
12367C********************************************************************
12368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12369 SAVE
12370
12371 PARAMETER ( PIMASS = 0.13D0,
12372 & TINY = 1.D-10 )
12373
12374C input/output channels
12375 INTEGER LI,LO
12376 COMMON /POINOU/ LI,LO
12377C 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
12384C 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)
12389C general process information
12390 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12391 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12392C 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
12405C 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)
12416C 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)
12430C 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)
12434C 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
12437C 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)
12442C 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
12450C 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
12462C initialize fragmentation
12463 CALL PHO_FRAINI(ISWMDL(6))
12464
12465C 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
12475C 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
12480C lower energy limit of initialization
12481 ETABLO = PARMDL(19)
12482 IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12483
12484C *** Commented by Chiara
12485C WRITE(LO,'(/,1X,A,2F12.1)')
12486C & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12487C WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12488C & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12489C & PMASS(1),PVIRT(1)
12490C WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12491C & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12492C & PMASS(2),PVIRT(2)
12493
12494C 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
12501C 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
12513C 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
12521C 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
12528C 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
12583C 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
12669C 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
12714C 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
12742C 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
12754CDECK ID>, PHO_REJSTA
12755 SUBROUTINE PHO_REJSTA(IMODE)
12756C********************************************************************
12757C
12758C MC rejection counting
12759C
12760C input IMODE -1 initialization
12761C -2 output of statistics
12762C
12763C********************************************************************
12764
12765 IMPLICIT NONE
12766
12767 SAVE
12768
12769C input/output channels
12770 INTEGER LI,LO
12771 COMMON /POINOU/ LI,LO
12772C 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
12779C 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
12790C initialization
12791 IF(IMODE.EQ.-1) THEN
12792 DO 100 I=1,NMXJ
12793 IFAIL(I) = 0
12794 100 CONTINUE
12795C
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
12839C 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
12854CDECK ID>, PHO_POSPOM
12855 SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12856C***********************************************************************
12857C
12858C registration of one cut pomeron (soft/semihard)
12859C
12860C input: IP particle combination the pomeron belongs to
12861C IND1,2 position of X values in /POSOFT/
12862C 1 corresponds to a valence-pomeron
12863C IGEN production process of mother particles
12864C IPOM pomeron number
12865C KCUT total number of cut pomerons and reggeons
12866C
12867C output: ISWAP exchange of x values
12868C IND1,2 increased by the number of partons belonging
12869C to the generated pomeron cut
12870C IREJ success/failure
12871C
12872C**********************************************************************
12873 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12874 SAVE
12875
12876 PARAMETER ( DEPS = 1.D-8 )
12877
12878C input/output channels
12879 INTEGER LI,LO
12880 COMMON /POINOU/ LI,LO
12881C 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
12888C internal rejection counters
12889 INTEGER NMXJ
12890 PARAMETER (NMXJ=60)
12891 CHARACTER*10 REJTIT
12892 INTEGER IFAIL
12893 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12894C 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)
12899C general process information
12900 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12901 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12902C 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)
12906C 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
12913C 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
12916C 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
12922C 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
12931C 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)
12941C 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
12945C 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
12967C 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
12975C 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
12991C pomeron resolved?
12992 IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
12993C 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
13006C 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
13028C 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
13049C one-pomeron cut
13050 WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13051C central diff. cut
13052 WGX(2) = WGXCDF
13053C diff. diss. of particle 1
13054 WGX(3) = WGXHSD(1)
13055C diff. diss. of particle 2
13056 WGX(4) = WGXHSD(2)
13057C double diff. dissociation
13058 WGX(5) = WGXHDD
13059C 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
13072C 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
13081C 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
13090C do not generate diffraction for events with only one cut pomeron
13091 IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13092
13093C do not generate recursive calls for remants with
13094C 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
13098C 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
13103C 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
13129C 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
13148C 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
13152C 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
13165C 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
13218C registration
13219
13220C 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
13226C strings formed by quarks
13227 ELSE
13228C 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
13234C 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
13246C 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
13252C strings formed by quarks
13253 ELSE
13254C 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
13260C 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
13272C 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
13287CDECK ID>, PHO_HADSP2
13288 SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13289C***********************************************************************
13290C
13291C split hadron momentum XMAX into two partons using
13292C lower cut-off: AS
13293C
13294C input: IFLB compressed particle code of particle to split
13295C XS1 sum of x values already selected
13296C XMAX maximal x possible
13297C
13298C output: XS1 new sum of x values (without first one)
13299C XSOFT1 field of selected x values
13300C
13301C**********************************************************************
13302 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13303 SAVE
13304
13305 PARAMETER ( DEPS = 1.D-8 )
13306
13307 DIMENSION XSOFT1(50)
13308
13309C input/output channels
13310 INTEGER LI,LO
13311 COMMON /POINOU/ LI,LO
13312C 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
13319C internal rejection counters
13320 INTEGER NMXJ
13321 PARAMETER (NMXJ=60)
13322 CHARACTER*10 REJTIT
13323 INTEGER IFAIL
13324 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13325C 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
13336C model exponents
13337 DATA PVMES1 /-0.5D0/
13338 DATA PVMES2 /-0.5D0/
13339 DATA PVBAR1 / 1.5D0/
13340 DATA PVBAR2 /-0.5D0/
13341C
13342 IREJ = 0
13343 ITMAX = 100
13344C
13345C mesonic particle
13346 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13347 XPOT1 = PVMES1+1.D0
13348 XPOT2 = PVMES2+1.D0
13349C baryonic particle
13350 ELSE
13351 XPOT1 = PVBAR1+1.D0
13352 XPOT2 = PVBAR2+1.D0
13353 ENDIF
13354 ITER = 0
13355 XREST= 1.D0-XS1
13356C 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
13373C
13374 XS1 = XSS1
13375 XSOFT1(1) = 1.D0-XSS1
13376 XSOFT1(2) = ZZ
13377C 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
13385CDECK ID>, PHO_HADSP3
13386 SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13387C***********************************************************************
13388C
13389C split hadron momentum XMAX into diquark & quark pair
13390C using lower cut-off: AS
13391C
13392C input: IFLB compressed particle code of particle to split
13393C XS1 sum of x values already selected
13394C XMAX maximal x possible
13395C
13396C output: XS1 new sum of x values
13397C XSOFT1 field of selected x values
13398C
13399C
13400C**********************************************************************
13401 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13402 SAVE
13403 PARAMETER ( DEPS = 1.D-8 )
13404
13405 DIMENSION XSOFT1(50),XSOFT2(50)
13406
13407C input/output channels
13408 INTEGER LI,LO
13409 COMMON /POINOU/ LI,LO
13410C 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
13417C internal rejection counters
13418 INTEGER NMXJ
13419 PARAMETER (NMXJ=60)
13420 CHARACTER*10 REJTIT
13421 INTEGER IFAIL
13422 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13423C 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
13433C 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/
13440C
13441 IREJ = 0
13442C
13443C determine exponents
13444C particle 1
13445C
13446 XMMIN = 0.3D0/ECMP
13447 XBMIN = 1.6D0/ECMP
13448C 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
13456C 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
13465C particle 2
13466C 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
13473C
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)
13478C 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
13486C 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
13497CDECK ID>, PHO_SOFTXX
13498 SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13499 & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13500C***********************************************************************
13501C
13502C select soft x values
13503C
13504C input: JM1,JM2 mother particle index in POEVT1
13505C (0 flavour not known before)
13506C MSPAR1,2 number of x values to select
13507C IVAL1,2 number valence quarks involved in hard
13508C scattering (0,1,2)
13509C MSM1,2 minimum number of soft x to get sampled
13510C XSUM1,2 sum of all x values samples up this call
13511C XMAX1,2 max. x value
13512C
13513C output XSUM1,2 new sum of x-values sampled
13514C XS1,2 field containing sampled x values
13515C
13516C x values of valence partons are first given
13517C
13518C***********************************************************************
13519 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13520 SAVE
13521
13522C input/output channels
13523 INTEGER LI,LO
13524 COMMON /POINOU/ LI,LO
13525C 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
13532C internal rejection counters
13533 INTEGER NMXJ
13534 PARAMETER (NMXJ=60)
13535 CHARACTER*10 REJTIT
13536 INTEGER IFAIL
13537 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13538C 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)
13543C 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
13551C 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)
13561C 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
13565C 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)
13570C 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
13573C 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
13602C 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
13607C 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
13616C 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
13627C particle 1
13628 XMMIN1 = MAX(XMIN1,XMMINA)
13629 XBMIN1 = MAX(XMIN1,XBMINA)
13630 XSMIN1 = MAX(XMIN1,XSMINA)
13631C 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
13648C 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
13667C particle 2
13668 XMMIN2 = MAX(XMIN2,XMMINA)
13669 XBMIN2 = MAX(XMIN2,XBMINA)
13670 XSMIN2 = MAX(XMIN2,XSMINA)
13671C 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
13688C 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
13711C 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
13725C 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
13781C 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
13813C first x entry
13814 XS1(1) = 1.D0 - XSS1
13815 XS2(1) = 1.D0 - XSS2
13816 XSUM1 = XSS1
13817 XSUM2 = XSS2
13818
13819C 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
13833C not enough phase space
13834 1000 CONTINUE
13835
13836 IFAIL(42) = IFAIL(42)+1
13837 IREJ = 1
13838
13839C 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
13868CDECK ID>, PHO_SELSXR
13869 SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13870 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13871C***********************************************************************
13872C
13873C select x values of soft string ends (rejection method)
13874C
13875C***********************************************************************
13876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13877 SAVE
13878
13879 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13880
13881C input/output channels
13882 INTEGER LI,LO
13883 COMMON /POINOU/ LI,LO
13884C 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
13891C 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)
13896C 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
13906C 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)
13910C 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
13924C
13925 IREJ = 0
13926C
13927 XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
13928 XMIN1 = MAX(AS/XMAX1,XMINK)
13929 XMIN2 = MAX(AS/XMAX2,XMINK)
13930C
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))
13938C
13939 10 CONTINUE
13940C
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
13953C
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
14011CDECK ID>, PHO_SELSX2
14012 SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14013 & XS1,XS2,IREJ)
14014C***********************************************************************
14015C
14016C select x values of soft string ends using PHO_RNDBET
14017C
14018C***********************************************************************
14019 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14020 SAVE
14021
14022 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
14023
14024C input/output channels
14025 INTEGER LI,LO
14026 COMMON /POINOU/ LI,LO
14027C 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
14034C 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)
14039C 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
14049C 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
14126CDECK ID>, PHO_SELSXS
14127 SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14128 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14129C***********************************************************************
14130C
14131C select x values of soft string ends (rescaling method)
14132C
14133C***********************************************************************
14134 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14135 SAVE
14136
14137 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14138
14139C input/output channels
14140 INTEGER LI,LO
14141 COMMON /POINOU/ LI,LO
14142C 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
14149C 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)
14154C 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
14164C 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
14246CDECK ID>, PHO_SELSXI
14247 SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14248 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14249C***********************************************************************
14250C
14251C select x values of soft string ends (sea independent from valence)
14252C
14253C***********************************************************************
14254 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14255 SAVE
14256
14257 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14258
14259C input/output channels
14260 INTEGER LI,LO
14261 COMMON /POINOU/ LI,LO
14262C 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
14269C 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)
14274C 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
14284C 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
14307C 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
14338C 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
14368CDECK ID>, PHO_SELCOL
14369 SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14370C********************************************************************
14371C
14372C color combinatorics
14373C
14374C input: ICO1,2 colors of incoming particle
14375C IMODE -2 output of initialization status
14376C -1 initialization
14377C ICINP(1) selection mode
14378C 0 QCD
14379C 1 large N_c expansion
14380C ICINP(2) max. allowed color
14381C 0 clear internal color counter
14382C 1 hadron into two colored objects
14383C 2 quark into quark gluon
14384C 3 gluon into gluon gluon
14385C 4 gluon into quark antiquark
14386C
14387C output: ICOA1,2 colors of first outgoing particle
14388C ICOB1,2 colors of second outgoing particle
14389C
14390C********************************************************************
14391 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14392 SAVE
14393
14394C input/output channels
14395 INTEGER LI,LO
14396 COMMON /POINOU/ LI,LO
14397C 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
14483CDECK ID>, ipho_diqu
14484 INTEGER FUNCTION ipho_diqu(iq1,iq2)
14485C***********************************************************************
14486C
14487C selection of diquark number (PDG convention)
14488C
14489C***********************************************************************
14490
14491 IMPLICIT NONE
14492
14493 SAVE
14494
14495 integer iq1,iq2
14496
14497C input/output channels
14498 INTEGER LI,LO
14499 COMMON /POINOU/ LI,LO
14500C 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
14507C 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
14513C external functions
14514 double precision DT_RNDM
14515
14516C 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
14538CDECK ID>, PHO_PARREM
14539 SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14540C**********************************************************************
14541C
14542C selection of particle remnant flavour(s) (quark or diquark)
14543C
14544C input: INDX index of particle in /POEVT1/
14545C IOUT parton which was taken out
14546C
14547C output: IREM remnant according to valence flavours
14548C IREJ 0 flavour combination possible
14549C 1 flavour combination impossible
14550C
14551C all particle ID are given according to PDG conventions
14552C
14553C**********************************************************************
14554
14555 IMPLICIT NONE
14556
14557 SAVE
14558
14559 integer INDX,IOUT,IREM,IREJ
14560
14561C input/output channels
14562 INTEGER LI,LO
14563 COMMON /POINOU/ LI,LO
14564C 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
14572C 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)
14582C 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
14586C 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
14600C external functions
14601 integer ipho_diqu
14602
14603C 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
14616C particle with flavour mixing
14617 if(ID1.eq.22) then
14618C photon
14619 IREM = -IOUT
14620 GOTO 100
14621 else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14622C 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
14630C 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
14641C pomeron and reggeon
14642 IREM = -IOUT
14643 GOTO 100
14644 endif
14645
14646C 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
14653C compare to flavour content
14654 IF(ABS(IOUT).LT.1000) THEN
14655C 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
14674C 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
14691C 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
14697C 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
14705CDECK ID>, PHO_VALFLA
14706 SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14707C***********************************************************************
14708C
14709C selection of valence flavour decomposition of particle IPAR
14710C
14711C input: IPAR particle index in /POEVT1/
14712C -1 initialization
14713C -2 output of statistics
14714C XMASS mass of particle
14715C (important for pomeron:
14716C mass dependent flavour sampling)
14717C
14718C output: IFL1,IFL2
14719C baryon: IFL1 diquark flavour
14720C (valence flavours according to PDG conventions)
14721C
14722C***********************************************************************
14723 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14724 SAVE
14725
14726 PARAMETER ( EPS = 0.1D0,
14727 & DEPS = 1.D-15)
14728
14729C input/output channels
14730 INTEGER LI,LO
14731 COMMON /POINOU/ LI,LO
14732C 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
14739C 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
14745C 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)
14755C 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
14759C 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
14777C 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
14794C not baryon
14795 IF(IBAR.EQ.0) THEN
14796
14797C photon
14798 IF(ID1.EQ.22) THEN
14799C 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
14812C 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
14820C pomeron, reggeon
14821 ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14822 IF(ISWMDL(19).EQ.0) THEN
14823C 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
14832C 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
14841C 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
14846C 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
14858C 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
14867C change sign for antiparticles
14868 if(ID1.lt.0) then
14869 IFL1 = -IFL1
14870 IFL2 = -IFL2
14871 endif
14872
14873************************************************************************
14874C check kinematic constraints
14875* IF((PHO_PMASS(IFL1,3).GT.E1)
14876* & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14877************************************************************************
14878
14879C 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
14884C initialization
14885
14886 ELSE IF(IPAR.EQ.-2) THEN
14887C 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
14897CDECK ID>, PHO_REGFLA
14898 SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14899C**********************************************************************
14900C
14901C selection of reggeon flavours
14902C
14903C input: JM1,JM2 position index of mother hadrons
14904C
14905C output: IFLR1,IFLR2 valence flavours according to
14906C PDG conventions and JM1,JM2
14907C IREJ 0 reggeon possible
14908C 1 reggeon impossible
14909C
14910C**********************************************************************
14911 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14912 SAVE
14913
14914 PARAMETER ( EPS = 0.1D0,
14915 & DEPS = 1.D-15)
14916
14917C input/output channels
14918 INTEGER LI,LO
14919 COMMON /POINOU/ LI,LO
14920C 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
14927C 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
14933C 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)
14943C 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
14950C 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
14959C 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
14981C 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
14986C 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
14991C initialization
14992 ELSE IF(JM1.EQ.-2) THEN
14993C 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
15002CDECK ID>, PHO_SEAFLA
15003 SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
15004C**********************************************************************
15005C
15006C selection of sea flavour content of particle IPAR
15007C
15008C input: IPAR particle index in /POEVT1/
15009C CHMASS available invariant string mass
15010C positive mass --> use BAMJET method
15011C negative mass --> SU(3) symmetric sea according
15012C to values given in PARMDL(1-6)
15013C IPAR -1 initialization
15014C -2 output of statistics
15015C
15016C output: sea flavours according to PDG conventions
15017C
15018C**********************************************************************
15019 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15020 SAVE
15021
15022 PARAMETER ( EPS = 0.1D0,
15023 & DEPS = 1.D-15)
15024
15025C input/output channels
15026 INTEGER LI,LO
15027 COMMON /POINOU/ LI,LO
15028C 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
15035C 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)
15040C 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
15047C 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
15062C 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
15075C initialization
15076 NFSEA = NFS
15077 ELSE IF(IPAR.EQ.-2) THEN
15078C 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
15086CDECK ID>, PHO_FLAUX
15087 SUBROUTINE PHO_FLAUX(EQUARK,K)
15088C***********************************************************************
15089C
15090C auxiliary subroutine to select flavours
15091C
15092C********************************************************************
15093 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15094 SAVE
15095
15096 PARAMETER ( DEPS = 1.D-14 )
15097
15098C input/output channels
15099 INTEGER LI,LO
15100 COMMON /POINOU/ LI,LO
15101C 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
15108C 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
15115C 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
15136C 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
15144C 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
15150CDECK ID>, PHO_BETAF
15151 DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15152C********************************************************************
15153C
15154C weights of different quark flavours
15155C
15156C********************************************************************
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
15169CDECK ID>, PHO_MCHECK
15170 SUBROUTINE PHO_MCHECK(J1,IREJ)
15171C********************************************************************
15172C
15173C check parton momenta for fragmentation
15174C
15175C input: J1 first string number
15176C /POEVT1/
15177C /POSTRG/
15178C
15179C output: /POEVT1/
15180C /POSTRG/
15181C IREJ 0 successful
15182C 1 failure
15183C
15184C in case of very small string mass:
15185C NNCH mass label of string
15186C 0 string
15187C -1 octett baryon / pseudo scalar meson
15188C 1 decuplett baryon / vector meson
15189C IBHAD hadron number according to CPC,
15190C string will be treated as resonance
15191C (sometimes far off mass shell)
15192C
15193C constant WIDTH ( 0.01GeV ) determines range of acceptance
15194C
15195C********************************************************************
15196 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15197 SAVE
15198
15199 PARAMETER ( WIDTH = 0.01D0,
15200 & DEPS = 1.D-15 )
15201
15202C input/output channels
15203 INTEGER LI,LO
15204 COMMON /POINOU/ LI,LO
15205C 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
15212C 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
15218C 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)
15228C 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
15232C 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
15239C 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
15247C 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
15272C 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
15296C 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
15321CDECK ID>, PHO_POMCOR
15322 SUBROUTINE PHO_POMCOR(IREJ)
15323C********************************************************************
15324C
15325C join quarks to gluons in case of too small masses
15326C
15327C input: /POEVT1/
15328C /POSTRG/
15329C IREJ -1 initialization
15330C -2 output of statistics
15331C
15332C output: /POEVT1/
15333C /POSTRG/
15334C IREJ 0 successful
15335C 1 failure
15336C
15337C
15338C********************************************************************
15339 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15340 SAVE
15341
15342 PARAMETER ( EPS = 1.D-10 )
15343
15344C input/output channels
15345 INTEGER LI,LO
15346 COMMON /POINOU/ LI,LO
15347C 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
15354C 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
15360C 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)
15370C 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
15374C 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
15389C *** Commented by Chiara
15390C WRITE(LO,'(/1X,A,2I8)')
15391C & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15392 RETURN
15393 ENDIF
15394C
15395 IREJ = 0
15396C
15397 NITER = 100
15398 ITER = 0
15399 ICTOT = ICTOT+ISTR
15400 IF(ISWMDL(25).LE.0) RETURN
15401C debug string entries
15402 IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15403C
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
15414C
15415C 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)
15423C 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
15449C 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)
15454C join quarks to gluon
15455 IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15456C 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
15490C 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
15510C 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
15516C 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)
15522C 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
15528C 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)
15536C delete string K in /POSTRG/
15537 NCODE(K) = -999
15538C update string I in /POSTRG/
15539 NPOS(1,I) = IPOS
15540 NPOS(2,I) = IP1
15541 NPOS(3,I) = -IP2
15542C 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
15562CDECK ID>, PHO_MASCOR
15563 SUBROUTINE PHO_MASCOR(IREJ)
15564C********************************************************************
15565C
15566C check and adjust parton momenta for fragmentation
15567C
15568C input: /POEVT1/
15569C /POSTRG/
15570C IREJ -1 initialization
15571C -2 output of statistics
15572C
15573C output: /POEVT1/
15574C /POSTRG/
15575C IREJ 0 successful
15576C 1 failure
15577C
15578C in case of very small string mass:
15579C - direct manipulation of /POEVT1/ and /POEVT2/
15580C - string will be deleted from /POSTRG/ (label -99)
15581C
15582C********************************************************************
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
15590C input/output channels
15591 INTEGER LI,LO
15592 COMMON /POINOU/ LI,LO
15593C 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
15600C internal rejection counters
15601 INTEGER NMXJ
15602 PARAMETER (NMXJ=60)
15603 CHARACTER*10 REJTIT
15604 INTEGER IFAIL
15605 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15606C 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
15612C 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)
15622C 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
15626C 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
15641C *** Commented by Chiara
15642C WRITE(LO,'(/1X,A,2I8/)')
15643C & '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
15652C 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
15667C 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)
15680C 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
15712C select masses to correct
15713 IBHAD(I) = 0
15714 NNCH(I) = 0
15715C correction needed?
15716C 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
15730C 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
15768C
15769C correction necessary?
15770 IF(IBHAD(I).NE.0) THEN
15771C 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
15823C 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
15829C copy parents of strings
15830C 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
15864C 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
15909C 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)
15914C 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
15933C 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
15939C 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
15947C 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
15954C 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
15959C jump to next iteration
15960 GOTO 50
15961 ENDIF
15962 90 CONTINUE
15963 100 CONTINUE
15964C 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
15973CDECK ID>, PHO_PARCOR
15974 SUBROUTINE PHO_PARCOR(MODE,IREJ)
15975C********************************************************************
15976C
15977C conversion of string partons (using JETSET masses)
15978C
15979C input: MODE >0 position index of corresponding string
15980C -1 initialization
15981C -2 output of statistics
15982C
15983C output: /POSTRG/
15984C IREJ 1 combination of strings impossible
15985C 0 successful combination
15986C
15987C********************************************************************
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
15995C input/output channels
15996 INTEGER LI,LO
15997 COMMON /POINOU/ LI,LO
15998C 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
16005C internal rejection counters
16006 INTEGER NMXJ
16007 PARAMETER (NMXJ=60)
16008 CHARACTER*10 REJTIT
16009 INTEGER IFAIL
16010 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16011C 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
16017C 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)
16027C 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
16031C 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
16046C
16047 IF(IMODE.GT.0) THEN
16048 ICH = 0
16049 I1 = JMOHEP(1,IMODE)
16050 I2 = ABS(JMOHEP(2,IMODE))
16051C 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
16074C
16075C two parton configurations
16076C -----------------------------------------
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
16086C 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
16102C
16103C multi parton configurations
16104C ---------------------------------
16105 ELSE
16106C
16107C 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
16118C
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
16129C select method
16130 IF(ITER.GT.2) GOTO 230
16131
16132C 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
16169C
16170 230 CONTINUE
16171C
16172C 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
16178C 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
16199C 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
16208C 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
16217C 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
16235C 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
16248C 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)
16252C update /POSTRG/
16253 I = IPHIST(1,IMODE)
16254 NPOS(1,I) = IPOS
16255 NPOS(2,I) = IP1
16256 NPOS(3,I) = -IP2
16257 ENDIF
16258C 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
16271C 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
16291C initialization
16292 RETURN
16293
16294 ELSE IF(IMODE.EQ.-2) THEN
16295C final output
16296 RETURN
16297 ENDIF
16298 END
16299
16300CDECK ID>, PHO_STRING
16301 SUBROUTINE PHO_STRING(IMODE,IREJ)
16302C********************************************************************
16303C
16304C calculation of string combinatorics, Lorentz boosts and
16305C particle codes
16306C
16307C - splitting of gluons
16308C - strings will be built up from pairs of partons
16309C according to their color labels
16310C with IDHEP(..) = -1
16311C - there can be other particles between to string partons
16312C (these will be unchanged by string construction)
16313C - string mass fine correction
16314C
16315C input: IMODE 1 complete string processing
16316C -1 initialization
16317C -2 output of statistics
16318C
16319C output: /POSTRG/
16320C IREJ 1 combination of strings impossible
16321C 0 successful combination
16322C 50 rejection due to user cutoffs
16323C
16324C********************************************************************
16325 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16326 SAVE
16327
16328 PARAMETER ( DEPS = 1.D-15,
16329 & EPS = 1.D-5 )
16330
16331C input/output channels
16332 INTEGER LI,LO
16333 COMMON /POINOU/ LI,LO
16334C 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
16341C general process information
16342 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16343 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16344C internal rejection counters
16345 INTEGER NMXJ
16346 PARAMETER (NMXJ=60)
16347 CHARACTER*10 REJTIT
16348 INTEGER IFAIL
16349 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16350C 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)
16355C 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
16367C 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)
16377C 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
16381C 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
16388C 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
16394C 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
16414C 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
16513C 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
16548C 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
16563C 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
16572C 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)
16617C further parton involved?
16618 IF(ICOL1.NE.0) GOTO 65
16619 JM2 = IPOS
16620C 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)
16624C 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))
16629C 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
16647C 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
16659C
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)
16686C further parton involved?
16687 IF(ICOL1.NE.0) GOTO 165
16688 170 CONTINUE
16689 JM2 = IPOS
16690C 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)
16694C 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))
16699C 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
16713C 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
16725C 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
16737C 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
16753C 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
16762C 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
16775CDECK ID>, PHO_STRFRA
16776 SUBROUTINE PHO_STRFRA(IREJ)
16777C********************************************************************
16778C
16779C do all fragmentation of strings
16780C
16781C output: IREJ 0 successful
16782C 1 rejection
16783C 50 rejection due to user cutoffs
16784C
16785C********************************************************************
16786
16787 IMPLICIT NONE
16788
16789 SAVE
16790
16791C input/output channels
16792 INTEGER LI,LO
16793 COMMON /POINOU/ LI,LO
16794C 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)
16798C 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
16805C general process information
16806 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16807 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16808C 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)
16813C 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
16818C 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)
16828C 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
16832C 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
16873C 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
16882C copy partons to fragmentation code JETSET
16883 IP = 0
16884 IP_old = 1
16885
16886 DO 300 J=1,ISTR
16887
16888C 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
16896C 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
16922C 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
16967C 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
16977C set Lund counter
16978 N = IP
16979 if(IP.eq.0) goto 299
16980
16981C 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
17018C 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
17027C 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
17036C 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
17050C 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
17059C 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
17070C copy hadrons back to POEVT1 / POEVT2
17071
17072 IF(IP.GT.0) THEN
17073 NHEP1 = NHEP+1
17074
17075 NLINES = PYK(0,1)
17076
17077C 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
17116C 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
17149C 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
17173C 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
17202C 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
17211CDECK ID>, PHO_EVEINI
17212 SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17213C********************************************************************
17214C
17215C prepare /POEVT1/ for new event
17216C
17217C first subroutine called for each event
17218C
17219C input: P1(4) particle 1
17220C P2(4) particle 2
17221C IMODE 0 general initialization
17222C 1 initialization of particles and kinematics
17223C 2 initialization after internal rejection
17224C
17225C output: IP1,IP2 index of interacting particles
17226C
17227C********************************************************************
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
17236C input/output channels
17237 INTEGER LI,LO
17238 COMMON /POINOU/ LI,LO
17239C 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
17246C 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)
17251C general process information
17252 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17253 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17254C 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)
17261C 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)
17265C 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
17271C 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
17284C 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
17292C 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)
17302C 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
17306C 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
17312C 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
17320C 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
17332C
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
17342C 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
17350C initialization of particle kinematics
17351
17352C 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
17384C 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
17396C 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
17405C 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
17418C 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
17426C reset of mother/daughter relations only (IMODE = 2)
17427
17428C 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
17447CDECK ID>, PHO_CSINT
17448 SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17449C********************************************************************
17450C
17451C calculate cross sections by interpolation
17452C
17453C input: IP particle combination
17454C IFPA/B particle PDG number
17455C IHLA/B particle helicity (photons only)
17456C ECM c.m. energy (GeV)
17457C PVIR2A virtuality of particle A (GeV**2, positive)
17458C PVIR2B virtuality of particle B (GeV**2, positive)
17459C
17460C output: cross sections stored in /POCSEC/
17461C
17462C********************************************************************
17463 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17464 SAVE
17465
17466 PARAMETER ( EPS = 1.D-5,
17467 & DEPS = 1.D-15 )
17468
17469C input/output channels
17470 INTEGER LI,LO
17471 COMMON /POINOU/ LI,LO
17472C 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)
17476C 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
17483C 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)
17488C 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
17494C 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
17507C 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
17523C 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
17528C 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
17532C nothing to calculate
17533 IF(IDEB(15).GE.20)
17534 & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17535 RETURN
17536 ELSE
17537
17538C 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
17546C 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
17569C 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
17580C 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))
17589C 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))
17593C diffraction of trans. photons corresponds mainly to leading twist
17594 FSUD(K) = 1.D0
17595 ENDIF
17596C 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))
17600C 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
17605C 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
17619C 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
17623C 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
17628C 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)
17639C 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
17644C 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
17649C 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
17656C 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)
17662C 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
17684C 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
17717C 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
17733C 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)
17755C 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
17787C 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)
17790C minimum bias event generation
17791 IF(IPAMDL(115).GE.1) THEN
17792C 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
17795C 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
17800C 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
17808C 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
17819C 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
17854CDECK ID>, PHO_PRIMKT
17855 SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17856C***********************************************************************
17857C
17858C give primordial kt to partons entering hard scatterings and
17859C remants connected to hard parton-parton interactions by color flow
17860C
17861C input: IMODE -2 output of statistics
17862C -1 initialization
17863C 1 sampling of primordial kt
17864C IF first entry in /POEVT1/ to check
17865C IL last entry in /POEVT1/ to check
17866C PTCUT current value of PTCUT to distinguish
17867C between soft and hard
17868C
17869C output: IREJ 0 success
17870C 1 failure
17871C
17872C***********************************************************************
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
17884C input/output channels
17885 INTEGER LI,LO
17886 COMMON /POINOU/ LI,LO
17887C 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
17894C 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)
17899C 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)
17903C 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
17910C 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
17924C 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)
17934C 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
17951C 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
17956C 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
17971C hard scattering number
17972 NHD = IPHIST(1,I+1)
17973 ICOM = I
17974 K = LSIDX(NHD/100)
17975C 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
17988C 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
17993C 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
18009C 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
18028C 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
18037C 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
18058C 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
18073C 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
18093C calculate primordial kt
18094
18095C something to do?
18096 IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18097
18098C add transverse momentum (overwrite /POEVT1/ entries)
18099 DO 200 J=1,2
18100 IF(IBAL(J).GT.1) THEN
18101C 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
18110C 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)
18118C 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
18126C 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
18136C 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
18152C transformation of hard scattering final states (including ISR)
18153
18154C 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)
18157C 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
18162C 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
18166C 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
18187C debug output
18188C 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
18205C 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
18220C debug output
18221C 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
18245C initialization
18246
18247 ELSE IF(IMODE.EQ.-1) THEN
18248
18249C output of statistics etc.
18250
18251 ELSE IF(IMODE.EQ.-2) THEN
18252
18253C 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
18263CDECK ID>, PHO_PARTPT
18264 SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18265C********************************************************************
18266C
18267C assign to soft partons
18268C
18269C input: IMODE -2 output of statistics
18270C -1 initialization
18271C 0 sampling of pt for soft partons belonging to
18272C soft Pomerons
18273C 1 sampling of pt for soft partons belonging to
18274C hard Pomerons
18275C IF first entry in /POEVT1/ to check
18276C IL last entry in /POEVT1/ to check
18277C PTCUT current value of PTCUT to distinguish
18278C between soft and hard
18279C
18280C output: IREJ 0 success
18281C 1 failure
18282C
18283C (soft pt is sampled by call to PHO_SOFTPT)
18284C
18285C********************************************************************
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
18294C input/output channels
18295 INTEGER LI,LO
18296 COMMON /POINOU/ LI,LO
18297C 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
18304C 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)
18309C 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)
18313C 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
18321C 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)
18331C 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
18341C 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
18351C count entries to modify
18352 IENTRY = 0
18353 PTCUT2 = PTCUT**2
18354 EMIN = 1.D20
18355 IPEAK = 1
18356 ISTART = IF
18357
18358C 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
18375C 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
18401C something wrong
18402
18403 ELSE
18404 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18405 CALL PHO_ABORT
18406 ENDIF
18407
18408C 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
18415C nothing to do
18416 IF(IENTRY.LE.1) RETURN
18417
18418C 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
18427C 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
18470C 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
18477C 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
18525C 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
18537C 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
18550C initialization / output of statistics
18551 1000 CONTINUE
18552 CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18553
18554 END
18555
18556CDECK ID>, PHO_SOFTPT
18557 SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18558C***********************************************************************
18559C
18560C select pt of soft string ends
18561C
18562C input: ISOFT number of soft partons
18563C -1 initialization
18564C >=0 sampling of p_t
18565C -2 output of statistics
18566C PTCUT cutoff for soft strings
18567C PTMAX maximal allowed PT
18568C XV field of x values
18569C IV 0 sea quark
18570C 1 valence quark
18571C
18572C output: /POINT3/ containing parameters AAS,BETAS
18573C PTSOF filed with soft pt values
18574C
18575C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18576C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18577C ISWMDL(3/4) = 2 photon wave function
18578C ISWMDL(3/4) = 10 no soft P_t assignment
18579C
18580C***********************************************************************
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
18589C input/output channels
18590 INTEGER LI,LO
18591 COMMON /POINOU/ LI,LO
18592C 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
18599C 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)
18604C 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
18611C 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
18621C 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
18627C selection of pt
18628 IF(ISOFT.GE.0) THEN
18629 CALLS = CALLS + 1.D0
18630C 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)
18637C valence partons
18638 IF(IV(I).EQ.1) THEN
18639 BETA = BETAS(1)
18640C 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
18658C sea partons
18659 ELSE IF(IV(I).EQ.0) THEN
18660 BETA = BETAS(3)
18661C 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
18682C 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
18689C
18690*400 CONTINUE
18691C
18692C single parton only
18693 ELSE
18694 IMODE = ISWMDL(3)
18695C valence partons
18696 IF(IV(1).EQ.1) THEN
18697 BETA = BETAS(1)
18698C 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
18716C sea partons
18717 ELSE IF(IV(1).EQ.0) THEN
18718 BETA = BETAS(3)
18719C 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
18737C 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
18747C 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
18756C 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
18767CDECK ID>, PHO_SELPT
18768 SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18769C***********************************************************************
18770C
18771C select pt from different distributions
18772C
18773C input: EE energy (for initialization only)
18774C otherwise x value of corresponding parton
18775C PTLOW lower pt limit
18776C PTHIGH upper pt limit
18777C (PTHIGH > 20 will cause DEXP underflows)
18778C
18779C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18780C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18781C IMODE = 2 dNs/dP_t according photon wave function
18782C IMODE = 10 no sampling
18783C
18784C IMODE = -100+IMODE initialization according to
18785C given limitations
18786C
18787C output: PTS sampled pt value
18788C initialization:
18789C BETA soft pt slope in central region
18790C
18791C***********************************************************************
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
18800C input/output channels
18801 INTEGER LI,LO
18802 COMMON /POINOU/ LI,LO
18803C 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
18810C 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)
18815C 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
18822C 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
18825C 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
18832C initialization
18833
18834 IF(IMODE.LT.0) GOTO 100
18835
18836 PX = PTHIGH
18837 PTS = 0.D0
18838
18839C 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
18849C 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
18884C 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
18891C 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
18899C initialization
18900 100 CONTINUE
18901 PTSMIN = PTLOW
18902 PTSMAX = PTHIGH
18903 PTCON = PTHIGH
18904C calculation of parameters
18905 INIT = IMODE+100
18906 AAS = 0.D0
18907
18908C 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
18936C 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
18976C 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
18985C 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
18999CDECK ID>, PHO_CONN0
19000 DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
19001C***********************************************************************
19002C
19003C auxiliary function to determine parameters of soft
19004C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
19005C
19006C internal factors: FS number of soft partons in soft Pomeron
19007C FH number of soft partons in hard Pomeron
19008C
19009C***********************************************************************
19010
19011 IMPLICIT NONE
19012
19013 SAVE
19014
19015C input/output channels
19016 INTEGER LI,LO
19017 COMMON /POINOU/ LI,LO
19018C 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
19021C 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
19042CDECK ID>, PHO_CONN1
19043 DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
19044C***********************************************************************
19045C
19046C auxiliary function to determine parameters of soft
19047C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
19048C
19049C internal factors: FS number of soft partons in soft Pomeron
19050C FH number of soft partons in hard Pomeron
19051C
19052C***********************************************************************
19053
19054 IMPLICIT NONE
19055
19056 SAVE
19057
19058C input/output channels
19059 INTEGER LI,LO
19060 COMMON /POINOU/ LI,LO
19061C 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
19064C 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
19085CDECK ID>, PHO_MSHELL
19086 SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19087C********************************************************************
19088C
19089C rescaling of momenta of two partons to put both
19090C on mass shell
19091C
19092C input: PA1,PA2 input momentum vectors
19093C XM1,2 desired masses of particles afterwards
19094C P1,P2 changed momentum vectors
19095C
19096C********************************************************************
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
19104C input/output channels
19105 INTEGER LI,LO
19106 COMMON /POINOU/ LI,LO
19107C 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
19114C 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
19123C 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
19131C 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))
19161C 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
19175C 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
19182C 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
19189C 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
19201C 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
19219CDECK ID>, PHO_GLU2QU
19220 SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19221C********************************************************************
19222C
19223C split gluon with index I in POEVT1
19224C (massless gluon assumed)
19225C
19226C input: /POEVT1/
19227C IG gluon index
19228C IQ1 first quark index
19229C IQ2 second quark index
19230C
19231C output: new quarks in /POEVT1/
19232C IREJ 1 splitting impossible
19233C 0 splitting successful
19234C
19235C********************************************************************
19236 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19237 SAVE
19238
19239 PARAMETER ( DEPS = 1.D-15,
19240 & EPS = 1.D-5 )
19241
19242C input/output channels
19243 INTEGER LI,LO
19244 COMMON /POINOU/ LI,LO
19245C 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
19252C 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
19258C 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)
19268C 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
19272C 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
19284C 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
19308C
19309C 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
19326C
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
19335C 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
19346C 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
19354C 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)
19359C 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
19369CDECK ID>, PHO_GLUSPL
19370 DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19371C*********************************************************************
19372C
19373C calculate quark - antiquark light cone momentum fractions
19374C according to Altarelli-Parisi g->q aq splitting function
19375C (symmetric z interval assumed)
19376C
19377C input: ZMIN minimal Z value allowed,
19378C 1-ZMIN maximal Z value allowed
19379C
19380C********************************************************************
19381 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19382 SAVE
19383
19384 PARAMETER ( ALEXP= 0.3333333333D0,
19385 & DEPS = 1.D-10 )
19386
19387C input/output channels
19388 INTEGER LI,LO
19389 COMMON /POINOU/ LI,LO
19390C 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
19425CDECK ID>, PHO_STDPAR
19426 SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19427C***********************************************************************
19428C
19429C select the initial parton x-fractions and flavors and
19430C the final parton momenta and flavours
19431C for standard Pomeron/Reggeon cuts
19432C
19433C input: IJM1 index of mother particle 1 in /POEVT1/
19434C IJM2 index of mother particle 2 in /POEVT1/
19435C IGEN production process of mother particles
19436C MSPOM soft cut Pomerons
19437C MHPOM hard or semihard cut Pomerons
19438C MSREG soft cut Reggeons
19439C MHDIR direct hard processes
19440C
19441C IJM1 -1 initialization of statistics
19442C -2 output of statistics
19443C
19444C output: partons are directly written to /POEVT1/,/POEVT2/
19445C
19446C structure of /POSOFT/
19447C XS1(I),XS2(I): x-values of initial partons
19448C IJSI1(I),IJSI2(I): flavor of initial parton
19449C 0 gluon
19450C 1,2,3,4 quarks
19451C negative antiquarks
19452C IJSF1(I),IJSF2(I): flavor of final state partons
19453C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19454C J=1 PX
19455C =2 PY
19456C =3 PZ
19457C =4 ENERGY
19458C
19459C***********************************************************************
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
19467C input/output channels
19468 INTEGER LI,LO
19469 COMMON /POINOU/ LI,LO
19470C 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
19477C 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)
19482C 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)
19486C general process information
19487 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19488 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19489C 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)
19493C 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
19500C 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)
19505C 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
19508C 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
19514C 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
19518C 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)
19525C 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)
19533C 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
19539C 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
19553C 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)
19563C 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
19567C internal rejection counters
19568 INTEGER NMXJ
19569 PARAMETER (NMXJ=60)
19570 CHARACTER*10 REJTIT
19571 INTEGER IFAIL
19572 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19573C 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)
19576C 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
19610C 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
19632C 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
19636C 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
19652C 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
19661C 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
19678C 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
19700C 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))
19707C 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
19719C get CM momentum
19720 XM12 = PMASSP(1)**2
19721 XM22 = PMASSP(2)**2
19722 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19723
19724C 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
19747C 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)
19751C initialize alpha_s calculation
19752 DUMMY = PHO_ALPHAS(0.D0,-4)
19753 ENDIF
19754
19755C 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
19761C position of first particle added to /POEVT2/
19762 NLOR1 = NHEP+1
19763
19764C ---------------- 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
19770C 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
19787C soft spectator partons
19788 ICA1 = 0
19789 ICA2 = 0
19790 ICB1 = 0
19791 ICB2 = 0
19792 IPDF1 = 0
19793 IPDF2 = 0
19794
19795C single resolved: QCD compton scattering
19796C ------------------------------
19797 IF(NPROHD(1).EQ.10) THEN
19798C 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
19802C 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
19806C single resolved: photon gluon fusion
19807C ---------------------------
19808 ELSE IF(NPROHD(1).EQ.11) THEN
19809C 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
19813C 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
19817C direct process (no remnant)
19818C ----------------------------
19819 ELSE IF(NPROHD(1).EQ.14) THEN
19820
19821 ENDIF
19822
19823C 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)
19832C 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
19839C 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
19872C 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
19920C 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
19931C ----------------- resolved processes -------------------
19932
19933C single Reggeon exchange
19934C ----------------------------
19935 ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
19936C 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
19943C 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
19951C registration
19952
19953C 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)
19959C 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
19967C 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
19975C
19976C multi Reggeon / Pomeron exchange
19977C----------------------------------------
19978 ELSE
19979C 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
19987C 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
19992C 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
20021C soft Pomeron final states
20022C -----------------------------------
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
20031C
20032 50 CONTINUE
20033
20034C soft Reggeon final states
20035C -----------------------------------------
20036 DO 75 I=1,MSREG
20037C 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
20045C 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)
20050C 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
20064C 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
20075C hard Pomeron final states
20076C ------------------------------------
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
20088C 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
20111C 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
20136C
20137C 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)
20146C 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
20153C 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
20186C 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
20235C end of resolved parton registration
20236 ENDIF
20237
20238 IF(MHDIR+MHPOM.GT.0) THEN
20239
20240 IF(ISWMDL(29).GE.1) THEN
20241C 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
20248C 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
20258C 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
20267C 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
20272C rejection treatment
20273 150 CONTINUE
20274 IFAIL(2) = IFAIL(2)+1
20275C reset counters
20276 KSPOM = KSPOMS
20277 KHPOM = KHPOMS
20278 KHDIR = KHDIRS
20279 KSREG = KSREGS
20280C 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
20290C 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
20298CDECK ID>, PHO_HARCOL
20299 SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20300 & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20301C*********************************************************************
20302C
20303C calculate color flow for hard resolved process
20304C
20305C input: IP1..4 flavour of partons (PDG convention)
20306C V parton subprocess Mandelstam variable V = t/s
20307C (lightcone momenta assumed)
20308C ICA,ICB color labels
20309C MSPR process number
20310C -1 initialization of statistics
20311C -2 output of statistics
20312C
20313C output: ICC,ICD color label of final partons
20314C
20315C (it is possible to use the same variables for in and output)
20316C
20317C**********************************************************************
20318 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20319 SAVE
20320
20321C input/output channels
20322 INTEGER LI,LO
20323 COMMON /POINOU/ LI,LO
20324C 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
20331C 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)
20336C 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
20344C 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
20354C 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
20377C
20378C 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
20399C 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
20404C
20405 IRC = 0
20406 IF(IPAMDL(21).EQ.1) THEN
20407C
20408C soft color re-connection option
20409C
20410 IF(MSPR.EQ.1) THEN
20411C 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
20424C 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
20437C 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
20452C
20453 IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20454C
20455C large Nc limit of all graphs
20456C
20457 IF(MSPR.EQ.1) THEN
20458C 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
20473C 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
20489C 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
20531C 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
20543C 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
20565C 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
20576C 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
20587C 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
20609C unknown process
20610 WRITE(LO,'(/1X,A,I3)')
20611 & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20612 CALL PHO_ABORT
20613 ENDIF
20614C
20615 ELSE
20616C
20617C color flow according to QCD leading order matrix element
20618C
20619 U = -(1.D0+V)
20620 IF(MSPR.EQ.1) THEN
20621C 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
20681C 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
20716C 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
20771C 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
20805C 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
20833C 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
20844C 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
20858C 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
20878C 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
20885C 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
20890C 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
20897C 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
20910C unknown process
20911 WRITE(LO,'(/1X,A,I3)')
20912 & 'PHO_HARCOL:ERROR:invalid process number',MSPR
20913 CALL PHO_ABORT
20914 ENDIF
20915 ENDIF
20916C
20917 100 CONTINUE
20918C 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
20921C 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
20925C 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
20947C
20948 ICC1 = IC1
20949 ICC2 = IC2
20950 ICD1 = IC3
20951 ICD2 = IC4
20952
20953 END
20954
20955CDECK ID>, PHO_HARCOR
20956 SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
20957C***********************************************************************
20958C
20959C substituite color in /POEVT2/
20960C
20961C input: ICOLD old color
20962C ICNEW new color
20963C
20964C***********************************************************************
20965 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20966 SAVE
20967
20968C input/output channels
20969 INTEGER LI,LO
20970 COMMON /POINOU/ LI,LO
20971
20972C 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)
20982C 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
21013CDECK ID>, PHO_HARREM
21014 SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
21015 & IUSED,IREJ)
21016C***********************************************************************
21017C
21018C sample color structure for initial quark/gluon of hard scattering
21019C and write hadron remnant to /POEVT1/
21020C
21021C input: JM1,2 index of mother particle in POEVT1
21022C IGEN mother particle production process
21023C IHPOS hard pomeron number
21024C INDXH index of hard parton
21025C positive for labels 1
21026C negative for labels 2
21027C IVAL 1 hard valence parton
21028C 0 hard sea parton connected by color flow with
21029C valence quarks
21030C -1 hard sea parton independent off valence
21031C quarks
21032C INDXS index of soft partons needed
21033C
21034C output: IC1,IC2 color label of initial parton
21035C IUSED number of soft X values used
21036C IREJ rejection flag
21037C
21038C**********************************************************************
21039 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21040 SAVE
21041
21042 PARAMETER ( TINY = 1.D-10 )
21043
21044C input/output channels
21045 INTEGER LI,LO
21046 COMMON /POINOU/ LI,LO
21047C 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
21054C 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)
21059C 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
21066C 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
21069C 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)
21077C 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
21091C 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)
21101C 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
21105C 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
21121C 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
21137C quark
21138C****************************************************************
21139
21140 IF(IJH.NE.21) THEN
21141
21142C 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
21157C 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
21171C 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
21180C 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
21215C 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
21222C
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
21236C 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
21243C
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
21264C 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
21271C
21272C 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
21293C 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
21307C
21308 IC1 = ICB1
21309 IC2 = 0
21310C
21311C gluon
21312C****************************************************************
21313C
21314C gluon from valence quarks
21315 ELSE
21316 IF(IVAL.EQ.1) THEN
21317C 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
21339C 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
21347C 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
21369C 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
21383C 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
21390C
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
21404C 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
21413C
21414C 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
21436C 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
21450C 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
21457C
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
21471C 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
21479C 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
21508C 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
21515C
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
21529C 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
21540C
21541C 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
21557C 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
21571C 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
21578C 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
21592C 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
21607C
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
21619CDECK ID>, PHO_HARDIR
21620 SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21621 & IREJ)
21622C**********************************************************************
21623C
21624C parton orientated formulation of direct scattering processes
21625C
21626C input:
21627C
21628C output: II particle combination (1..4)
21629C IVAL1,2 0 no valence quarks engaged
21630C 1 valence quarks engaged
21631C MSPAR1,2 number of realized soft partons
21632C MHPAR1,2 number of realized hard partons
21633C IREJ 1 failure
21634C 0 success
21635C
21636C**********************************************************************
21637 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21638 SAVE
21639
21640C input/output channels
21641 INTEGER LI,LO
21642 COMMON /POINOU/ LI,LO
21643C 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
21650C 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)
21655C 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
21659C 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
21666C 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
21669C 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)
21680C 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
21690C 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)
21698C 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)
21711C 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
21727C 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
21743C
21744C main loop to select hard and soft parton kinematics
21745C -----------------------------------------------------
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
21764C select hard V,X
21765 CALL PHO_HARSCA(1,II)
21766 XSS1 = XSS1+X1
21767 XSS2 = XSS2+X2
21768C 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
21783C 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
21805C valence quarks
21806 IVAL1 = IV1
21807 IVAL2 = IV2
21808 PDFVA(1,1) = 0.D0
21809 PDFVA(1,2) = 0.D0
21810C 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
21833C 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
21886C 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
21915C add photon/hadron remnant
21916
21917C 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
21937C 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
21971C double direct process
21972 ELSE IF(MSPR.EQ.14) THEN
21973 MSPAR1 = 0
21974 MSPAR2 = 0
21975 MHPAR1 = 1
21976 MHPAR2 = 1
21977
21978C 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
21991C 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
22008C process counting
22009 MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
22010 KSOFT = MAX(MSPAR1,MSPAR2)
22011 KHARD = MAX(MHPAR1,MHPAR2)
22012C 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
22055CDECK ID>, PHO_POMSCA
22056 SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
22057 & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
22058C**********************************************************************
22059C
22060C parton orientated formulation of soft and hard inelastic events
22061C
22062C
22063C input: II particle combiantion (1..4)
22064C MSPOM number of soft pomerons
22065C MHPOM number of semihard pomerons
22066C MSREG number of soft reggeons
22067C
22068C output: IVAL1,2 0 no valence quark engaged
22069C otherwise: position of valence quark engaged
22070C neg.number: gluon connected to valence quark
22071C by color flow
22072C MSPAR1,2 number of realized soft partons
22073C MHPAR1,2 number of realized hard partons
22074C IREJ 1 failure
22075C 0 success
22076C
22077C**********************************************************************
22078 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22079 SAVE
22080
22081 PARAMETER (TINY = 1.D-30 )
22082
22083C input/output channels
22084 INTEGER LI,LO
22085 COMMON /POINOU/ LI,LO
22086C 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
22093C 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)
22098C general process information
22099 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22100 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22101C 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)
22106C 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)
22111C 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)
22122C 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
22126C 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
22133C 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
22136C 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
22140C 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
22150C 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)
22158C 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)
22171C 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
22177C 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
22195C 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
22212C 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
22218C
22219C main loop to select hard and soft parton kinematics
22220C -----------------------------------------------------
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
22243C partons needed to construct soft/hard interactions
22244 MSPAR1 = 2*MSPOM+MSREG+MHPOM
22245 MSPAR2 = MSPAR1
22246 MHPAR1 = MHPOM
22247 MHPAR2 = MHPOM
22248
22249C number of strings
22250 MSCHA = 2*MSPOM+MSREG
22251 MHCHA = 2*MHPOM
22252
22253 KSOFT = MSCHA
22254 KHARD = MHCHA
22255
22256C 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
22283C 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
22302C
22303C select hard parton momenta
22304C ------------------- 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
22315C
22316C generate one resolved hard scattering
22317C
22318C 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)
22347C minimum bias option
22348 ELSE
22349 CALL PHO_HARSCA(2,II)
22350 ENDIF
22351
22352C 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
22391C 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
22405C 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)
22410C 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)
22414C 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
22427C 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
22484C 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
22518C 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
22531C 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
22537C hard scattering accepted
22538 IHARD = IHARD+1
22539 XSS1 = XSSS1
22540 XSS2 = XSSS2
22541 IFAIL(31) = IFAIL(31)-1
22542
22543 15 CONTINUE
22544
22545C ------------------- end of inner (hard) loop -------------------
22546 199 CONTINUE
22547
22548 MHPOM = IHARD
22549 MHPAR1 = IHARD
22550 MHPAR2 = IHARD
22551
22552C 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
22568C 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
22582C 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
22595C 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)
22621C 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
22626C select soft X values
22627 25 CONTINUE
22628C 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
22646C 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
22671C 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
22702C accepted
22703 MSPOM = MSPOM-(MSPAR1-MSG1)/2
22704 MSPAR1 = MSG1
22705 MSPAR2 = MSG2
22706C ------------ kinematics sampled ---------------
22707C 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
22717C end of loop
22718 XS1(1) = 1.D0 - XSS1
22719 XS2(1) = 1.D0 - XSS2
22720
22721C 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
22726C 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
22754C 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
22808C 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
22825CDECK ID>, PHO_HARX12
22826 SUBROUTINE PHO_HARX12
22827C**********************************************************************
22828C
22829C selection of x1 and x2 according to 1/x1*1/x2
22830C
22831C**********************************************************************
22832 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22833 SAVE
22834
22835 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22836
22837C input/output channels
22838 INTEGER LI,LO
22839 COMMON /POINOU/ LI,LO
22840C 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
2285110 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
22863CDECK ID>, PHO_HARDX1
22864 SUBROUTINE PHO_HARDX1
22865C**********************************************************************
22866C
22867C selection of x1 according to 1/x1
22868C ( x2 = 1 )
22869C
22870C**********************************************************************
22871 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22872 SAVE
22873
22874 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22875
22876C input/output channels
22877 INTEGER LI,LO
22878 COMMON /POINOU/ LI,LO
22879C 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
22899CDECK ID>, PHO_HARKIN
22900 SUBROUTINE PHO_HARKIN(IREJ)
22901C***********************************************************************
22902C
22903C selection of kinematic variables
22904C (resolved and direct processes)
22905C
22906C***********************************************************************
22907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22908 SAVE
22909
22910 PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
22911
22912C input/output channels
22913 INTEGER LI,LO
22914 COMMON /POINOU/ LI,LO
22915C 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
22922C 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
22929C 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
22939C 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
22954C------------- resolved processes -----------
22955 IF ( M.EQ.1 ) THEN
2295610 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
2296520 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
2297530 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
2298350 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
2299160 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
2299970 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
2300980 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
2301790 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
23025C------------- direct / single-resolved processes -----------
23026 ELSEIF ( M.EQ.10 ) THEN
23027100 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
23038110 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
23050120 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
23058130 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
23067C------------- (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
23082C---------------------------------------------
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
23114CDECK ID>, PHO_HARWGH
23115 SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23116C***********************************************************************
23117C
23118C calculate product of PDFs and coupling constants
23119C according to selected MSPR (process type)
23120C
23121C input: /POCKIN/
23122C
23123C output: PDS resulting from PDFs alone
23124C FDISTR complete weight function
23125C PDA,PDB fields containing the PDFs
23126C
23127C***********************************************************************
23128 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23129 SAVE
23130
23131 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23132
23133C input/output channels
23134 INTEGER LI,LO
23135 COMMON /POINOU/ LI,LO
23136C 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
23143C 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)
23148C 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
23155C 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
23161C 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
23165C 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
23169C 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
23174C 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
23184C 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)
23195C 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
23204C 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
23223C 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)
23264C 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)
23293C 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
23329C complete weight
23330 FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23331
23332C 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
23339CDECK ID>, PHO_HARSCA
23340 SUBROUTINE PHO_HARSCA(IMODE,IP)
23341C***********************************************************************
23342C
23343C PHO_HARSCA determines the type of hard subprocess, the partons
23344C taking part in this subprocess and the kinematic variables
23345C
23346C input: IMODE 1 direct processes
23347C 2 resolved processes
23348C -1 initialization
23349C -2 output of statistics
23350C IP 1-4 particle combination (hadron/photon)
23351C
23352C***********************************************************************
23353 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23354 SAVE
23355
23356 PARAMETER( EPS = 1.D-10,
23357 & DEPS = 1.D-30 )
23358
23359C input/output channels
23360 INTEGER LI,LO
23361 COMMON /POINOU/ LI,LO
23362C 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
23369C 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)
23374C internal rejection counters
23375 INTEGER NMXJ
23376 PARAMETER (NMXJ=60)
23377 CHARACTER*10 REJTIT
23378 INTEGER IFAIL
23379 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23380C 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
23384C 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
23391C 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)
23396C 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
23406C 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)
23419C 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)
23430C 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
23443C 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
23450C 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
23463C
23464C ----------------------------------------------I
23465C begin of iteration loop (resolved processes) I
23466C 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
23476C 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
23487C 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
23493C calculate remaining distribution
23494 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23495C 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
23503C check F against FMAX
23504 WEIGHT = F/(HWgx(MSPR)+DEPS)
23505 IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23506C-------------------------------------------------------------------
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
23517C-------------------------------------------------------------------
23518C I
23519C end of iteration loop (resolved processes) I
23520C --------------------------------------------I
23521C
23522C*********************************************************************
23523C
23524C direct processes
23525
23526 ELSE IF(IMODE.EQ.1) THEN
23527
23528C 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
23560C
23561C ----------------------------------------------I
23562C begin of iteration loop (direct processes) I
23563C 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
23573C 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
23601C 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
23608C calculate remaining distribution
23609 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23610
23611C 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
23619C check F against FMAX
23620 WEIGHT = F/(HWgx(MSPR)+DEPS)
23621 IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23622C-------------------------------------------------------------------
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
23633C-------------------------------------------------------------------
23634C I
23635C end of iteration loop (direct processes) I
23636C --------------------------------------------I
23637
23638 ELSE IF(IMODE.EQ.-1) THEN
23639
23640C 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
23646C 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
23654C *** Commented by Chiara
23655C WRITE(LO,'(/1X,A,/1X,A)')
23656C & 'PHO_HARSCA: activated hard processes',
23657C & '------------------------------------'
23658C WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
23659 DO 42 M=1,Max_pro_2
23660C WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23661C & (MH_pro_on(M,J),J=1,4)
23662 42 CONTINUE
23663 ENDIF
23664 RETURN
23665
23666 ELSE IF(IMODE.EQ.-2) THEN
23667
23668C 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
23725C the event is accepted now
23726C actualize counter for accepted events
23727 MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23728 IF(MSPR.EQ.-1) MSPR = 3
23729C
23730C find flavor of initial partons
23731C
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
23813C 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
23819C
23820C find flavour of final partons
23821C
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
23952C 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
23971C
23972C fill event record
23973C
23974 955 CONTINUE
23975 CALL PHO_SFECFE(SINPHI,COSPHI)
23976 ECM2 = ECMP/2.D0
23977C 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
23988C 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
24000C 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
24010C 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
24025CDECK ID>, PHO_HARFAC
24026 SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
24027C*********************************************************************
24028C
24029C initialization: find scaling factors and maxima of remaining
24030C weights
24031C
24032C input: PTCUT transverse momentum cutoff
24033C ECMI cms energy
24034C
24035C output: Hfac(-1:Max_pro_2) field for sampling hard processes
24036C
24037C*********************************************************************
24038 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24039 SAVE
24040
24041 PARAMETER ( MXABWT = 96 )
24042
24043C input/output channels
24044 INTEGER LI,LO
24045 COMMON /POINOU/ LI,LO
24046C 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
24053C 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)
24057C 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
24061C integration precision for hard cross sections (obsolete)
24062 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24063 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24064C 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
24074C 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
2410110 CONTINUE
24102
24103C 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
2410920 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
2412130 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)
2414540 CONTINUE
24146 S(4) = S(2)*(9./32.)
24147 DO 50 M=-1,8
24148 S2(M) = S2(M)+S(M)*WEIG(I2)*W
2414950 CONTINUE
2415060 CONTINUE
24151 DO 70 M=-1,8
24152 S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
2415370 CONTINUE
2415480 CONTINUE
24155 S1(4) = S1(4)*NF
24156 S1(6) = S1(6)*MAX(0,NF-1)
24157C
24158C 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
24174C
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)
24190C 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
24214C
24215C 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)
2421990 CONTINUE
24220C
24221C 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
24244CDECK ID>, PHO_HARWGX
24245 SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24246C**********************************************************************
24247C
24248C find maximum of remaining weight for MC sampling
24249C
24250C input: PTCUT transverse momentum cutoff
24251C ECM cms energy
24252C
24253C output: HWgx(-1:Max_pro_2) field for sampling hard processes
24254C
24255C**********************************************************************
24256 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24257 SAVE
24258
24259 PARAMETER ( NKM = 10 )
24260 PARAMETER ( TINY = 1.D-20 )
24261
24262C input/output channels
24263 INTEGER LI,LO
24264 COMMON /POINOU/ LI,LO
24265C 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
24272C 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
24282C 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
24299C 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
24322C 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)
24354C 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
24395C
24396 50 CONTINUE
24397 35 CONTINUE
24398 40 CONTINUE
24399
24400C 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
24415C 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
24433CDECK ID>, PHO_HARWGI
24434 SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24435C**********************************************************************
24436C
24437C auxiliary subroutine to find maximum of remaining weight
24438C
24439C input: ECMX current CMS energy
24440C PTCUT current pt cutoff
24441C NKON process label 1..5 resolved
24442C 6..7 direct particle 1
24443C 8..9 direct particle 2
24444C 10 double direct
24445C Z(3) transformed variable
24446C
24447C output: remaining weight
24448C
24449C**********************************************************************
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
24459C input/output channels
24460 INTEGER LI,LO
24461 COMMON /POINOU/ LI,LO
24462C 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
24469C 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)
24474C 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
24481C 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
24487C 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
24491C 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
24495C 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
24500C 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
24518C 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
24522C transformations
24523 Y1 = EXP(ALNH*Z(1))
24524 IF(NKON.LE.5) THEN
24525C 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
24532C direct kinematic 1
24533 X1 = 1.D0
24534 X2 = MIN(Y1,0.999999999999D0)
24535 ELSE IF(NKON.LE.9) THEN
24536C direct kinematic 2
24537 X1 = MIN(Y1,0.999999999999D0)
24538 X2 = 1.D0
24539 ELSE
24540C 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
24549C 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
24568C
24569 IF(NKON.LE.5) THEN
24570 DO 10 N=1,5
24571 F(N) = 0.D0
24572 10 CONTINUE
24573C 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)
24578C 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)
2458420 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
24590C 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
24611C 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
24632C 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
24655C 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
24662CDECK ID>, PHO_HARINI
24663 SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24664C**********************************************************************
24665C
24666C initialize calculation of hard cross section
24667C
24668C must not be called during MC generation
24669C
24670C***********************************************************************
24671 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24672 SAVE
24673
24674 PARAMETER ( DEPS = 1.D-10 )
24675
24676C input/output channels
24677 INTEGER LI,LO
24678 COMMON /POINOU/ LI,LO
24679C 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
24686C 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)
24691C 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
24697C 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)
24701C 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
24706C 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
24713C 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
24716C 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
24725C set local Pomeron c.m. system data
24726 IDPDG1 = IDP1
24727 IDPDG2 = IDP2
24728 PVIRTP(1) = PV1
24729 PVIRTP(2) = PV2
24730C initialize PDFs
24731 CALL PHO_ACTPDF(IDPDG1,1)
24732 CALL PHO_ACTPDF(IDPDG2,2)
24733C initialize alpha_s calculation
24734 DUMMY = PHO_ALPHAS(0.D0,-4)
24735C 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
24802C write out all settings
24803C *** Commented by Chiara
24804C IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24805C WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24806C & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24807C & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24808C & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
24809C1050 FORMAT(/,
24810C & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24811C & 5X,'particle 1 / particle 2:',2I8,/,
24812C & 5X,'min. PT :',F7.1,2X,A,/,
24813C & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24814C & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24815C & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24816C & 5X,'max. number of active flavours NF :',I3,/,
24817C & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24818C ENDIF
24819
24820 END
24821
24822CDECK ID>, PHO_HARINT
24823 SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24824C**********************************************************************
24825C
24826C interpolate cross sections and weights for hard scattering
24827C
24828C input: IPP particle combination (neg. for add. user cuts)
24829C ECM CMS energy (GeV)
24830C P2V1/2 particle virtualities (pos., GeV**2)
24831C I1 first subprocess to calculate
24832C I2 last subprocess to calculate
24833C <-1 only scales and cutoffs calculated
24834C K1 first variable to calculate
24835C K2 last variable to calculate
24836C MSPOM cross sections to use for pt distribution
24837C 0 reggeon
24838C >0 pomeron
24839C
24840C for K1 < 3 the soft pt distribution is also calculated
24841C
24842C output: interpolated values in HWgx, HSig, Hdpt
24843C
24844C***********************************************************************
24845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24846 SAVE
24847
24848 PARAMETER ( DEPS = 1.D-15,
24849 & DEPS2 = 2.D-15 )
24850
24851C input/output channels
24852 INTEGER LI,LO
24853 COMMON /POINOU/ LI,LO
24854C 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
24861C 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)
24866C 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
24873C 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
24876C 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
24879C 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
24884C 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
24887C 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)
24892C 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
24896C 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)
24907C 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)
24921C 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
24931C 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
24951C default minimum bias cutoff
24952 PTCUT(IP) = pho_ptcut(ECM,IP)
24953 ELSE
24954C user defined additional cutoff
24955 PTCUT(IP) = HSWCUT(4+IP)
24956 ENDIF
24957 PTWANT = PTCUT(IP)
24958
24959C ISR cutoffs
24960 Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
24961 Q2MISR(1) = MAX(P2V1,Q2CUT)
24962 Q2MISR(2) = MAX(P2V2,Q2CUT)
24963C cutoff for direct photon contribution to photon PDF
24964 PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
24965 PTA1 = PTANO(IP)
24966C 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
24984C 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
25003C 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
25010C 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
25017C 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
25024C 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
25035C 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)
25042C 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
25075C 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)
25089C***********************************************************************
25090C
25091C calculate energy-dependent transverse momentum cutoff
25092C
25093C***********************************************************************
25094
25095 IMPLICIT NONE
25096
25097 SAVE
25098
25099 double precision ECM
25100 integer IP
25101
25102C input/output channels
25103 INTEGER LI,LO
25104 COMMON /POINOU/ LI,LO
25105C 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
25112C 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
25121C 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
25125C 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
25132CDECK ID>, PHO_HARMCI
25133 SUBROUTINE PHO_HARMCI(IP,EMAXF)
25134C**********************************************************************
25135C
25136C initialize MC sampling and calculate hard cross section
25137C
25138C input: IP particle combination (neg. number for user cut)
25139C EMAXF maximum CMS energy for
25140C interpolation table in reference to PTCUT(1..4)
25141C
25142C***********************************************************************
25143 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25144 SAVE
25145
25146 PARAMETER (DEPS = 1.D-10,
25147 & PLARGE = 1.D20 )
25148
25149C input/output channels
25150 INTEGER LI,LO
25151 COMMON /POINOU/ LI,LO
25152C 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
25159C 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)
25163C 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)
25167C 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
25174C 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)
25179C 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
25182C 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
25187C 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)
25192C 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)
25203C 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)
25217C 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
25226C 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
25236C 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)
25256C energy too low
25257 IF(DELTA.LE.0.D0) GOTO 1000
25258
25259C 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
25282C 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
25299C 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
25306C 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
25317C 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
25343C 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
25353C 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
25383C 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
25411CDECK ID>, PHO_HARXR3
25412 SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25413C**********************************************************************
25414C
25415C differential cross section DSIG/(DETAC*DETAD*DPT)
25416C
25417C input: ECMH CMS energy
25418C PT parton PT
25419C ETAC pseudorapidity of parton C
25420C ETAD pseudorapidity of parton D
25421C
25422C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25423C
25424C**********************************************************************
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
25435C input/output channels
25436 INTEGER LI,LO
25437 COMMON /POINOU/ LI,LO
25438C 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)
25442C 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
25449C 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
25455C 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
25459C 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
2547110 CONTINUE
25472
25473 EC = EXP(ETAC)
25474 ED = EXP(ETAD)
25475C 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
25488C 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
25510C 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)
2552320 CONTINUE
25524C partial cross sections (including color and symmetry factors)
25525C 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))
25535C
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))
25544C complex part
25545 X=ABS(TP-UP)
25546 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25547C
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
25555CDECK ID>, PHO_HARXR2
25556 SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25557C**********************************************************************
25558C
25559C differential cross section DSIG/(DETAC*DPT)
25560C
25561C input: ECMH CMS energy
25562C PT parton PT
25563C ETAC pseudorapidity of parton C
25564C
25565C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25566C
25567C**********************************************************************
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
25577C input/output channels
25578 INTEGER LI,LO
25579 COMMON /POINOU/ LI,LO
25580C 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
2559110 CONTINUE
25592C
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
2560720 CONTINUE
2560830 CONTINUE
25609 END
25610
25611CDECK ID>, PHO_HARXD2
25612 SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25613C**********************************************************************
25614C
25615C differential cross section DSIG/(DETAC*DPT) for direct processes
25616C
25617C input: ECMH CMS energy of scattering system
25618C PT parton PT
25619C ETAC pseudorapidity of parton C
25620C
25621C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25622C
25623C**********************************************************************
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
25632C input/output channels
25633 INTEGER LI,LO
25634 COMMON /POINOU/ LI,LO
25635C 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)
25640C 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
25647C 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
25654C 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
25660C 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
25664C 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
25668C 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
25673C 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
25690C direct particle 1
25691 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25692 EC = EXP(ETAC)
25693 ED = ECMH/PT-EC
25694C 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
25708C 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
25735C parton distribution (times x)
25736 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25737 S1 = PDB(0)
25738C 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
25759C partial cross sections (including color and symmetry factors)
25760C direct photon matrix elements
25761 DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25762 DSIGM(11) = (UU+TT)/(UP*TP)
25763C
25764 DSIGM(10) = FACTOR*DSIGM(10)*S2
25765 DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25766C complex part
25767 X=ABS(TP-UP)
25768 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25769C
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
25780C
25781C 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)
25785C 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
25799C 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
25826C parton distribution (times x)
25827 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25828 S1 = PDA(0)
25829C 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
25850C partial cross sections (including color and symmetry factors)
25851C direct photon matrix elements
25852 DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
25853 DSIGM(13) = (UU+TT)/(UP*TP)
25854C
25855 DSIGM(12) = FACTOR*DSIGM(12)*S2
25856 DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
25857C complex part
25858 X=ABS(TP-UP)
25859 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25860C
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
25873CDECK ID>, PHO_HARXPT
25874 SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
25875C**********************************************************************
25876C
25877C differential cross section DSIG/DPT
25878C
25879C input: ECMH CMS energy of scattering system
25880C PT parton PT
25881C IPRO 1 resolved processes
25882C 2 direct processes
25883C 3 resolved and direct processes
25884C
25885C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
25886C
25887C**********************************************************************
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
25896C input/output channels
25897 INTEGER LI,LO
25898 COMMON /POINOU/ LI,LO
25899C 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)
25903C 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)
25908C 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
25915C 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
25922C integration precision for hard cross sections (obsolete)
25923 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25924 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25925C 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
25929C 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
25945C 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
25968C 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
25989C 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))
25994C hadronic part
25995 DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
25996
25997C 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
26001C 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
26011CDECK ID>, PHO_HARXTO
26012 SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
26013C**********************************************************************
26014C
26015C total hard cross section (perturbative QCD, Parton Model)
26016C
26017C input: ECMH CMS energy of scattering system
26018C PTCUTR PT cutoff for resolved processes
26019C PTCUTD PT cutoff for direct processes (photon, Pomeron)
26020C
26021C output: DSIGMC(0:MARPR2) cross sections for given cutoff
26022C DSDPTC(0:MARPR2) differential cross sections at cutoff
26023C
26024C note: COMPLEX*16 DSIGMC
26025C DOUBLE PRECISION DSDPTC
26026C
26027C**********************************************************************
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
26035C input/output channels
26036 INTEGER LI,LO
26037 COMMON /POINOU/ LI,LO
26038C 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)
26043C 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
26050C 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
26057C 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)
26061C integration precision for hard cross sections (obsolete)
26062 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26063 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26064C 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
26068C 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
26085C
26086 IF ( PTCUTR.GE.EEC ) GOTO 100
26087C
26088C 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)
26123C
26124C integration for direct processes
26125 IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26126C
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
26162C
26163 170 CONTINUE
26164C
26165C 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
26189C hadronic cross section
26190 DSIGMC(14) = R*FACC*AKFAC
26191C leptonic cross section
26192 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26193 DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26194C 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
26200C 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
26206C total sum (hadronic)
26207 DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26208 DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26209
26210 END
26211
26212CDECK 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)
26215C********************************************************************
26216C
26217C initial state radiation according to DGLAP evolution equations
26218C (backward evolution, no spin effects)
26219C
26220C input: IHPOM index of hard Pomeron
26221C negative: delete all previous entries
26222C P1,P2 4 momenta of hard scattered final partons
26223C (in CMS of hard scattering)
26224C IPF1,2 flavours of final partons
26225C IPA1,2 flavours of initial partons
26226C IV1,2 valence quark labels (0/1)
26227C Q2H momentum transfer (squared, positive)
26228C XH1,XH2 x values of initial partons
26229C XHMAX1,2 max. x values allowed
26230C
26231C output: all emitted partons in /POPISR/, final state
26232C partons are the first two entries
26233C shower evolution traced in /PODGL1/
26234C IPB1,2 flavours of new initial partons
26235C XISR1,2 x values of new initial partons
26236C IVO1,2 valence quark labels (0/1)
26237C
26238C attention: quark numbering according to PDG convention,
26239C but 0 for gluons
26240C
26241C********************************************************************
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
26251C input/output channels
26252 INTEGER LI,LO
26253 COMMON /POINOU/ LI,LO
26254C 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
26261C internal rejection counters
26262 INTEGER NMXJ
26263 PARAMETER (NMXJ=60)
26264 CHARACTER*10 REJTIT
26265 INTEGER IFAIL
26266 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26267C 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)
26272C 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
26279C 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
26283C 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
26289C 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
26294C 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
26298C 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
26307C 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)
26311C 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
26329C 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
26336C
26337 10 CONTINUE
26338 NACC = 0
26339 IDMO(1) = IDPDG1
26340 IDMO(2) = IDPDG2
26341C
26342C 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
26363C
26364C 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
26379C
26380 ISH(1) = 1
26381 ISH(2) = 1
26382 XPSH(1,1) = XH1
26383 XPSH(2,1) = XH2
26384C
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
26391C
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
26395C
26396C 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
26421C
26422C main generation loop
26423C -------------------------------------------------
26424 100 CONTINUE
26425C 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)
26442C INDX now parton position of parton to become solved
26443C 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)
26448C check available x
26449 XMIP = XHMI(IP)
26450C 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
26461C 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
26467C DGLAP weights
26468 ZMIN = XP/XHMA(IP)
26469 ZMAX = XP/(XP+XMIP)
26470 CF = 4./3.
26471C 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)))
26481C 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
26492C 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
26508C 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
26520C
26521C rejection loop for z,t sampling
26522C ------------------------------------
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)
26529C clean up event
26530 IREJ = 1
26531 GOTO 10
26532 ENDIF
26533C 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
26543C
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
26549C
26550 215 CONTINUE
26551C sample new t value
26552 TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26553 Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26554C debug output
26555 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26556 & 'PHO_HARISR: pre-selected Q2:',Q2NEW
26557C 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))
26568C 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
26575C debug output
26576 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26577 & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26578C selection of z
26579 CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26580C debug output
26581 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26582 & 'PHO_HARISR: pre-selected ZZ',ZZ
26583C 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
26591C 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
26635C 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
26661C generation of next branching
26662 IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26663
26664 800 CONTINUE
26665
26666C 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)
26673C 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
26698C parton kinematics
26699 IF(NACC.GT.0) THEN
26700C 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)
26719C 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
26749C 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
26752C 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)
26761C 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)
26807C 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
26826C
26827 IF(NGEN.GT.1) THEN
26828C time-like shower generated
26829 EE4 = EE3-PC(IPA,4)
26830 PZ4 = PZ3-PC(IPA,3)
26831 PP4 = SQRT(PT3**2+PZ4**2)
26832C Lorentz boost
26833 GAM = (EE4*PJE-PP4*PJZ)/XMS4
26834 BEG = (PJE*PP4-EE4*PJZ)/XMS4
26835C 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
26847C 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
26863C 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
26875C 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
26905C 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)
26927C
26928C 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
26944C 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
26972CDECK ID>, PHO_HARZSP
26973 SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
26974C*********************************************************************
26975C
26976C sampling of z values from DGLAP kernels
26977C
26978C input: IFLA,IFLB parton flavours
26979C NFSH flavours involved in hard processes
26980C ZMIN minimal ZZ allowed
26981C ZMAX maximal ZZ allowed
26982C
26983C output: ZZ z value
26984C
26985C*********************************************************************
26986 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26987 SAVE
26988
26989 PARAMETER ( DEPS = 1.D-10 )
26990
26991C input/output channels
26992 INTEGER LI,LO
26993 COMMON /POINOU/ LI,LO
26994C 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
27001C 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
27015C
27016 IF(IFLB.EQ.0) THEN
27017 IF(IFLA.EQ.0) THEN
27018C 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
27025C 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
27035C 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
27041C 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
27053C 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
27066CDECK ID>, PHO_ALPHAE
27067 DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
27068C**********************************************************************
27069C
27070C calculation of ALPHA_em
27071C
27072C input: Q2 scale in GeV**2
27073C
27074C**********************************************************************
27075
27076 IMPLICIT NONE
27077
27078 SAVE
27079
27080 DOUBLE PRECISION Q2
27081
27082C input/output channels
27083 INTEGER LI,LO
27084 COMMON /POINOU/ LI,LO
27085C 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
27103CDECK ID>, PHO_ALPHAS
27104 DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27105C**********************************************************************
27106C
27107C calculation of ALPHA_S
27108C
27109C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
27110C 2 lambda_QCD**2 for PDF 2 evolution
27111C 3 lambda_QCD**2 for hard scattering
27112C Q2 scale in GeV**2
27113C
27114C initialization needed:
27115C IMODE = 0 lambda values taken from PDF table
27116C -1 given Q2 is 4-flavour lambda 1
27117C -2 given Q2 is 4-flavour lambda 2
27118C -3 given Q2 is 4-flavour lambda 3
27119C
27120C
27121C**********************************************************************
27122
27123 IMPLICIT NONE
27124
27125 SAVE
27126
27127 DOUBLE PRECISION Q2
27128 INTEGER IMODE
27129
27130C input/output channels
27131 INTEGER LI,LO
27132 COMMON /POINOU/ LI,LO
27133C 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)
27138C 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
27142C 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
27205CDECK ID>, PHO_DFWRAP
27206 SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27207C**********************************************************************
27208C
27209C wrapper for diffraction dissociation in hadron-nucleus and
27210C nucleus-nucleus collisions with DPMJET
27211C
27212C input: MODE 1: transformation into CMS
27213C 2: transformation into Lab
27214C JM1/2 indices of old mother particles
27215C JM1/2N indices of new mother particles
27216C
27217C**********************************************************************
27218
27219 IMPLICIT NONE
27220
27221 SAVE
27222
27223 INTEGER MODE,JM1,JM2
27224
27225C input/output channels
27226 INTEGER LI,LO
27227 COMMON /POINOU/ LI,LO
27228C 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
27236C 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)
27246C 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
27250C 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
27261C 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
27272C 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))
27285C 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
27298C 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
27323C 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
27333C 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
27350CDECK ID>, PHO_DIFDIS
27351 SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27352 & MSOFT,MHARD,IREJ)
27353C***********************************************************************
27354C
27355C sampling of diffractive events of different kinds,
27356C (produced particles stored in /POEVT1/)
27357C
27358C input: IDIF1/2 diffractive process particle 1/2
27359C 0 elastic/quasi-elastic scattering
27360C 1 diffraction dissociation
27361C IMOTH1/2 index of mother particles in /POEVT1/
27362C SPROB suppression factor (survival probability) for
27363C resolved diffraction dissociation
27364C IMODE mode of operation
27365C 0 sampling of diffractive cut
27366C 1 sampling of enhanced cut
27367C 2 sampling of diffractive cut without
27368C scattering (needed for double-pomeron)
27369C -1 initialization
27370C -2 output of statistics
27371C
27372C output: MSOFT number of generated soft strings
27373C MHARD number of generated hard strings
27374C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
27375C 0 quasi elastic scattering
27376C 1 low-mass diffractive dissociation
27377C 2 soft high-mass diffractive dissociation
27378C 3 hard resolved diffractive dissociation
27379C 4 hard direct diffractive dissociation
27380C IREJ rejection label
27381C 0 successful generation of partons
27382C 1 failure
27383C
27384C***********************************************************************
27385 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27386 SAVE
27387
27388 PARAMETER ( EPS = 1.D-7,
27389 & DEPS = 1.D-10)
27390
27391C input/output channels
27392 INTEGER LI,LO
27393 COMMON /POINOU/ LI,LO
27394C 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
27401C general process information
27402 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27403 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27404C internal rejection counters
27405 INTEGER NMXJ
27406 PARAMETER (NMXJ=60)
27407 CHARACTER*10 REJTIT
27408 INTEGER IFAIL
27409 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27410C 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)
27414C 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)
27420C 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
27423C 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)
27427C 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)
27432C 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
27439C 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
27442C 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
27449C 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)
27459C 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
27463C 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
27476C initialization
27477 RETURN
27478 ELSE IF(IMODE.EQ.-2) THEN
27479C output of statistics
27480 RETURN
27481 ENDIF
27482
27483 IREJ = 0
27484C mass cuts
27485 PIMASS = 0.140D0
27486C 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
27494C 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
27511C 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
27526C 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
27535C 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
27545C 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))
27552C 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
27564C 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)
27573C 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
27578C 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
27587C 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
27592C 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
27596C 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
27615C main rejection loop
27616C -------------------------------
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
27635C 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
27646C
27647 NSLP = 0
27648 NCOR = 0
27649 55 CONTINUE
27650
27651C calculation of kinematics
27652 DO 100 I=1,2
27653C 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
27664C vector meson dominance assumed
27665 XMASS(I) = AMP(I)
27666 CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27667C 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
27679C 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
27691C 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
27701C 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
27706C not double pomeron scattering
27707 IF(IMODE.NE.2) THEN
27708C sample diffractive interaction processes
27709 DO 120 I=1,2
27710 IF(IPAR(I).NE.0) THEN
27711C 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
27721C 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
27726C 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
27735C 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
27741C diffractive pomeron-hadron interaction
27742 IPAR(I) = 10+IPROC(I)
27743 ENDIF
27744C 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
27751C actualize debug information
27752 IF(IMODE.EQ.1) THEN
27753 IDIFR1 = IPAR(1)
27754 IDIFR2 = IPAR(2)
27755 ENDIF
27756C 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
27764C 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)
27767C 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
27790C double-pomeron scattering?
27791 IF(IMODE.EQ.2) GOTO 150
27792
27793C diffractive final states
27794 DO 300 I=1,2
27795 110 CONTINUE
27796 IF(IPAR(I).EQ.0) THEN
27797C 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
27804C 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)
27824C 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
27833C 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)
27840C 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
27854C particle-pomeron scattering
27855 IF(IPAR(I).LE.4) THEN
27856C 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
27868C 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
27877C 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)
27902C 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
27910C 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
27924CDECK ID>, PHO_DIFPRO
27925 SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
27926 & IPROC,ISAM,JSAM,KSAM,IDIR)
27927C*********************************************************************
27928C
27929C sampling of diffraction dissociation process
27930C
27931C input: IP particle combination
27932C ICUT user imposed limitations
27933C ID1/2 PDG particle code of scattering particles
27934C XMASS diffractively produced mass (GeV)
27935C P2V1/2 virtuality of scattering particles (Gev**2)
27936C SPROB suppression factor for resolved single and
27937C double diffraction dissociation
27938C
27939C output: IRPOC process ID
27940C ISAM number of cut pomerons (soft)
27941C JSAM number of cut reggeons
27942C KSAM number of cut pomerons (hard)
27943C IDIR direct hard interaction
27944C
27945C*********************************************************************
27946 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27947 SAVE
27948
27949C input/output channels
27950 INTEGER LI,LO
27951 COMMON /POINOU/ LI,LO
27952C 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
27959C general process information
27960 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27961 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27962C 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)
27967C 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
27980C rapidity gap survival probability
27981 SPRO = 1.D0
27982 IF(ISWMDL(28).GE.1) SPRO = SPROB
27983C 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)
27990C non-diffractive hadron-pomeron interaction
27991 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
27992C 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
28023CDECK ID>, PHO_DIFPAR
28024 SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
28025 & IPOSH1,IPOSH2,IMODE,IREJ)
28026C***********************************************************************
28027C
28028C perform string construction for diffraction dissociation
28029C
28030C input: IMOTH1,2 index of mother particles in POEVT1
28031C IGENM production process of mother particles
28032C IFL1,IFL2 particle numbers
28033C (IDPDG,IDBAM for quasi-elas. hadron)
28034C IPAR 0 quasi-elasic scattering
28035C 1 single string configuration
28036C 2 two string configuration
28037C P1 massive 4 momentum of first
28038C P1(6) virtuality/squ.mass of particle (GeV**2)
28039C P1(7) virtuality of Pomeron (neg, GeV**2)
28040C P2 massive 4 momentum of second particle
28041C IMODE 1 diffraction dissociation
28042C 2 double-pomeron scattering
28043C
28044C output: IPOSH1,2 index of the particles in /POEVT1/
28045C IREJ 0 successful string construction
28046C 1 no string construction possible
28047C
28048C***********************************************************************
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
28057C input/output channels
28058 INTEGER LI,LO
28059 COMMON /POINOU/ LI,LO
28060C 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
28067C internal rejection counters
28068 INTEGER NMXJ
28069 PARAMETER (NMXJ=60)
28070 CHARACTER*10 REJTIT
28071 INTEGER IFAIL
28072 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28073C 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)
28079C 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)
28084C 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
28089C 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)
28099C 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
28112C 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
28116C 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
28125C 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
28130C diffraction dissociation
28131 ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28132C 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
28143C 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
28154C invalid IPAR
28155 ELSE
28156 WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28157 CALL PHO_ABORT
28158 ENDIF
28159
28160C 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
28166CDECK ID>, PHO_QELAST
28167 SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28168C**********************************************************************
28169C
28170C sampling of quasi elastic processes
28171C
28172C input: IPROC 2 purely elastic scattering
28173C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
28174C IPROC 4 double pomeron scattering
28175C IPROC -1 initialization
28176C IPROC -2 output of statistics
28177C JM1/2 index of initial particle 1/2
28178C
28179C output: initial and final particles in /POEVT1/ involving
28180C polarized resonances in /POEVT1/ and decay
28181C products
28182C
28183C IREJ 0 successful
28184C 1 failure
28185C 50 user rejection
28186C
28187C**********************************************************************
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
28196C input/output channels
28197 INTEGER LI,LO
28198 COMMON /POINOU/ LI,LO
28199C 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
28206C 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)
28210C 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)
28216C 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)
28221C 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)
28225C 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
28239C 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)
28249C 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
28265C 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
28274C 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))
28296C 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
28308C get CM momentum
28309 AM12 = PMI(1)**2
28310 AM22 = PMI(2)**2
28311 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28312
28313C production process of mother particles
28314 IGEN = IPHIST(2,NPOSD(1))
28315 if(IGEN.eq.0) IGEN = IPROC
28316
28317 ICALL = ICALL + 1
28318C main rejection label
28319 50 CONTINUE
28320C 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
28346C 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
28360C 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
28365C 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
28372C 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
28377C fill /POEVT1/
28378 DO 200 I=1,2
28379 K = 3-I
28380 IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28381C 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
28388C 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
28397C search for vector mesons
28398 DO 300 I=I1,I2
28399C 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
28407C back transformation
28408 CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28409 & GAMBED(2),GAMBED(3))
28410
28411C 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
28425C 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
28448CDECK ID>, PHO_CDIFF
28449 SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28450C**********************************************************************
28451C
28452C preparation of /POEVT1/ for double-pomeron scattering
28453C
28454C input: IMOTH1/2 index of mother particles in /POEVT1/
28455C
28456C IMODE 1 sampling of pomeron-pomeron scattering
28457C -1 initialization
28458C -2 output of statistics
28459C
28460C output: MSOFT number of generated soft strings
28461C MHARD number of generated hard strings
28462C IREJ 0 accepted
28463C 1 rejected
28464C 50 user rejection
28465C
28466C**********************************************************************
28467 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28468 SAVE
28469
28470 PARAMETER ( EPS = 1.D-10,
28471 & DEPS = 1.D-10)
28472
28473C input/output channels
28474 INTEGER LI,LO
28475 COMMON /POINOU/ LI,LO
28476C 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
28483C internal rejection counters
28484 INTEGER NMXJ
28485 PARAMETER (NMXJ=60)
28486 CHARACTER*10 REJTIT
28487 INTEGER IFAIL
28488 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28489C 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)
28494C general process information
28495 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28496 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28497C 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
28504C 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
28507C 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)
28511C 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
28517C 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
28524C 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)
28534C 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
28544C 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
28555C 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
28573C find mother particle production process
28574 IGEN = IPHIST(2,IMOTH1)
28575 if(IGEN.eq.0) IGEN = 4
28576
28577C 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
28586C 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
28597C 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
28603C 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
28608C 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
28627C 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
28631C 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
28635C 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
28639C 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
28658C 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
28681C 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
28691C update debug information
28692 KSPOM = KSPOMS+ISAM
28693 KSREG = KSREGS+JSAM
28694 KHPOM = KHPOMS+KSAM
28695 KHDIR = KHDIRS+IDIR
28696C 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
28700C 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
28708C 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
28724CDECK ID>, PHO_SAMASS
28725 SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28726C**********************************************************************
28727C
28728C resonance mass sampling of quasi elastic processes
28729C
28730C input: IFLA PDG number of particle
28731C IFLA -1 initialization
28732C IFLA -2 output of statistics
28733C
28734C output: RMASS particle mass (in GeV)
28735C
28736C**********************************************************************
28737 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28738 SAVE
28739
28740 PARAMETER(EPS = 1.D-10 )
28741
28742C input/output channels
28743 INTEGER LI,LO
28744 COMMON /POINOU/ LI,LO
28745C 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
28752C 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)
28757C 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
28765C*****************************************************************
28766C initialization of tables
28767 IF(IFLA.EQ.-1) THEN
28768C
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
28778C calculate table of dsig/dm
28779 CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28780C 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
28791C 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
28799C 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
28815C
28816C**************************************************
28817C 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
28824C
28825C********************************************************
28826C sampling of RMASS
28827 ELSE
28828C 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
28837C quasi-elastic production of h*
28838 ELSE IF(IFLA.EQ.91) THEN
28839 RMASS = 0.35D0
28840 RETURN
28841C 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
28848C
28849C sample mass of vector mesonsn / two-pi background
28850 XI = DT_RNDM(RMASS) + EPS
28851C 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
28871C 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
28888CDECK ID>, PHO_DSIGDM
28889 SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
28890C**********************************************************************
28891C
28892C differential cross section DSIG/DM of low mass enhancement
28893C
28894C input: RMA(4,NTABM) mass values
28895C output: XMA(4,NTABM) DSIG/DM of resonances
28896C 1 rho production
28897C 2 omega production
28898C 3 phi production
28899C 4 pi-pi continuum
28900C
28901C**********************************************************************
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
28910C input/output channels
28911 INTEGER LI,LO
28912 COMMON /POINOU/ LI,LO
28913C 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
28920C 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)
28925C 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
28930C 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
28939C 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
28947C 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
28955CDECK ID>, PHO_SDECAY
28956 SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
28957C**********************************************************************
28958C
28959C decay of single resonance of /POEVT1/:
28960C decay in helicity frame according to polarization, isotropic
28961C decay and decay with limited transverse phase space possible
28962C
28963C ATTENTION:
28964C reference to particle number of CPC has to exist
28965C
28966C input: NPOS position in /POEVT1/
28967C ISP 0 decay according to phase space
28968C 1 decay according to transversal polarization
28969C 2 decay according to longitudinal polarization
28970C 3 decay with limited phase space
28971C ILEV decay mode to use
28972C 1 strong only
28973C 2 strong and ew of tau, charm, and bottom
28974C 3 strong and electro-weak decays
28975C negative: remove mother resonance after decay
28976C
28977C output: /POEVT1/,/POEVT2/ final particles according to decay mode
28978C
28979C**********************************************************************
28980 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28981 SAVE
28982
28983 PARAMETER ( EPS = 1.D-15,
28984 & DEPS = 1.D-10 )
28985
28986C input/output channels
28987 INTEGER LI,LO
28988 COMMON /POINOU/ LI,LO
28989C 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
28996C 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)
29001C 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
29006C 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)
29016C 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
29020C 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)
29033C 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)
29038C 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
29048C comment entry
29049 IF(ISTHEP(NPOS).GT.11) RETURN
29050
29051C 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
29057C 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
29069C 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
29093C 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
29111C 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
29116C boost
29117 GBET = PTOT/AMIST
29118 GAM = PHEP(4,NPOS)/AMIST
29119
29120 IF(ID(3).EQ.0) THEN
29121C two particle decay
29122 CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29123 ELSE
29124C 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
29145C 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
29159C 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
29168CDECK ID>, PHO_SDECY2
29169 SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29170C**********************************************************************
29171C
29172C isotropic/anisotropic two particle decay in CM system,
29173C (transversely/longitudinally polarized boson into two
29174C pseudo-scalar mesons)
29175C
29176C**********************************************************************
29177 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29178 SAVE
29179
29180C input/output channels
29181 INTEGER LI,LO
29182 COMMON /POINOU/ LI,LO
29183C 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
29202C no polarization
29203 COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
29204 ELSE IF(ISP.EQ.1) THEN
29205C 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
29211C 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
29228CDECK ID>, PHO_SDECY3
29229 SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29230C**********************************************************************
29231C
29232C isotropic/anisotropic three particle decay in CM system,
29233C (transversely/longitudinally polarized boson into three
29234C pseudo-scalar mesons)
29235C
29236C**********************************************************************
29237 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29238 SAVE
29239
29240 PARAMETER ( DEPS = 1.D-30,
29241 & EPS = 1.D-15 )
29242
29243C input/output channels
29244 INTEGER LI,LO
29245 COMMON /POINOU/ LI,LO
29246C 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
29252C 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
29330C 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
29344C 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
29355C 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
29367C selection of the sperical coordinates of particle 3
29368 CALL PHO_SFECFE(SIF(3),COF(3))
29369 IF(ISP.EQ.0) THEN
29370C no polarization
29371 COD(3) = 2.D0*DT_RNDM(S2)-1.D0
29372 ELSE IF(ISP.EQ.1) THEN
29373C 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
29379C 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
29390C 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
29422CDECK ID>, PHO_DFMASS
29423 DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29424C**********************************************************************
29425C
29426C sampling of Mx diffractive mass distribution within
29427C limits XMIN, XMAX
29428C
29429C input: XMIN,XMAX mass limitations (GeV)
29430C PREF2 original particle mass/ reference mass
29431C (squared, GeV**2)
29432C PVIRT2 particle virtuality
29433C IMODE M**2 mass distribution
29434C 1 1/(M**2+Q**2)
29435C 2 1/(M**2+Q**2)**alpha
29436C -1 1/(M**2-Mref**2+Q**2)
29437C -2 1/(M**2-Mref**2+Q**2)**alpha
29438C
29439C output: diffractive mass (GeV)
29440C
29441C**********************************************************************
29442 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29443 SAVE
29444
29445 PARAMETER(EPS = 1.D-10)
29446
29447C input/output channels
29448 INTEGER LI,LO
29449 COMMON /POINOU/ LI,LO
29450C 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
29457C 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)
29462C 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
29481C 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
29488C 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)
29502C 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
29510CDECK ID>, PHO_DIFSLP
29511 SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29512 & TT,SLWGHT,IREJ)
29513C**********************************************************************
29514C
29515C sampling of T (Mandelstam variable) distribution within
29516C certain limits TMIN, TMAX
29517C
29518C input: IDF1,2 type of diffractive vertex
29519C 0 elastic/quasi-elastic scattering
29520C 1 diffraction dissociation
29521C IVEC1,2 vector meson IDs in case of quasi-elastic
29522C scattering, otherwise 0
29523C XM1 mass of diffractive system 1 (GeV)
29524C XM2 mass of diffractive system 2 (GeV)
29525C XMX max. mass of diffractive system (GeV)
29526C
29527C output: TT squared momentum transfer ( < 0, GeV**2)
29528C SLWGHT weight to allow for mass-dependent slope
29529C IREJ 0 successful sampling
29530C 1 masses too big for given T range
29531C
29532C**********************************************************************
29533 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29534 SAVE
29535
29536 PARAMETER(EPS = 1.D-10)
29537
29538C input/output channels
29539 INTEGER LI,LO
29540 COMMON /POINOU/ LI,LO
29541C 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
29548C 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)
29553C internal rejection counters
29554 INTEGER NMXJ
29555 PARAMETER (NMXJ=60)
29556 CHARACTER*10 REJTIT
29557 INTEGER IFAIL
29558 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29559C 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)
29565C 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
29578C 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
29585C 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
29588C 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)
29591C 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
29600C
29601C range of momentum transfer t
29602 TMIN = -PARMDL(68)
29603 TMAX = -PARMDL(69)
29604C 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))
29614C
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)
29627C
29628C calculation of slope (mass-dependent parametrization)
29629 IF(IDF1+IDF2.GT.0) THEN
29630C 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)
29641C
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
29659C elastic/quasi-elastic scattering
29660 IF(ISWMDL(13).EQ.0) THEN
29661C 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
29665C 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
29678C
29679C determine max. abs(t) to avoid underflows
29680 TMAXP = -25.D0/SLOPE
29681 TMAXA = MAX(TMAX,TMAXP)
29682C
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
29694C
29695C 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)
29701C
29702C 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
29711CDECK ID>, PHO_DIFKIN
29712 SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29713C**********************************************************************
29714C
29715C calculation of diffractive kinematics
29716C
29717C input: XMP1 mass of outgoing particle system 1 (GeV)
29718C XMP2 mass of outgoing particle system 2 (GeV)
29719C TT momentum transfer (GeV**2, negative)
29720C
29721C output: PMOM1(5) four momentum of outgoing system 1
29722C PMOM2(5) four momentum of outgoing system 2
29723C IREJ 0 kinematics consistent
29724C 1 kinematics inconsistent
29725C
29726C**********************************************************************
29727 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29728 SAVE
29729
29730 PARAMETER(EPS = 1.D-10,
29731 & DEPS = 0.001)
29732
29733C input/output channels
29734 INTEGER LI,LO
29735 COMMON /POINOU/ LI,LO
29736C 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
29743C 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)
29749C 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
29757C 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
29762C general kinematic constraints
29763 IREJ = 1
29764 IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29765
29766C 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
29773C 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
29780C 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
29796C 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
29810C debug output / precision check
29811 IF(IDEB(49).GE.0) THEN
29812C 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
29825C 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
29834CDECK ID>, PHO_VECRES
29835 SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
29836C**********************************************************************
29837C
29838C sampling of vector meson resonance in diffractive processes
29839C (nothing done for hadrons)
29840C
29841C input: /POSVDM/ VDMFAC factors
29842C
29843C output: IVEC 0 incoming hadron
29844C 1 rho 0
29845C 2 omega
29846C 3 phi
29847C 4 pi+/pi- background
29848C RMASS mass of vector meson (GeV)
29849C IDPDG particle ID according to PDG
29850C IDBAM particle ID according to CPC
29851C
29852C**********************************************************************
29853 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29854 SAVE
29855
29856 PARAMETER(EPS = 1.D-10)
29857
29858C input/output channels
29859 INTEGER LI,LO
29860 COMMON /POINOU/ LI,LO
29861C 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
29868C 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)
29873C 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)
29876C 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
29881C particle code translation
29882 DIMENSION ITRANS(4)
29883C rho0,omega,phi,pi+/pi-
29884 DATA ITRANS /113, 223, 333, 92 /
29885
29886 IDPDO = IDPDG
29887C
29888C 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
29897C
29898 IDPDG = ITRANS(K)
29899 IDBAM = ipho_pdg2id(IDPDG)
29900 IVEC = K
29901C sample mass of vector meson
29902 CALL PHO_SAMASS(IDPDG,RMASS)
29903
29904C 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
29910C sample mass of two-pion system
29911 CALL PHO_SAMASS(IDPDG,RMASS)
29912
29913C 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
29953C 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
29962CDECK ID>, PHO_DIFRES
29963 SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
29964 & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
29965C**********************************************************************
29966C
29967C list of resonance states for low mass resonances
29968C
29969C input: IDMOTH PDG ID of mother particle
29970C IVAL1,2 quarks (photon only)
29971C
29972C output: IDPDG list of PDG IDs for possible resonances
29973C IDBAM list of corresponding CPC IDs
29974C RMASS mass
29975C RGAMS decay width
29976C RMASS additional weight factor
29977C LISTL entries in current list
29978C
29979C**********************************************************************
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
29988C input/output channels
29989 INTEGER LI,LO
29990 COMMON /POINOU/ LI,LO
29991C 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
29998C 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
30003C 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
30027C 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
30037C 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
30061C 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
30072CDECK ID>, PHO_MASSAD
30073 SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30074 & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30075C***********************************************************************
30076C
30077C fine-correction of low mass strings to mass of corresponding
30078C resonance or two particle threshold
30079C
30080C input: IFLMO PDG ID of mother particle
30081C IFL1,2 requested parton flavours
30082C (not used at the moment)
30083C PMASS reference mass (mass of mother particle)
30084C XMCON conjecture of mass
30085C
30086C output: XMOUT output mass (adjusted input mass)
30087C moved ot nearest mass possible
30088C IDPDG PDG resonance ID
30089C IDcpc CPC resonance ID
30090C
30091C**********************************************************************
30092 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30093 SAVE
30094
30095 PARAMETER ( DEPS = 1.D-8 )
30096
30097C input/output channels
30098 INTEGER LI,LO
30099 COMMON /POINOU/ LI,LO
30100C 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
30107C 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)
30112C 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)
30125C 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
30138C 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
30148C mass small?
30149 PMASSL = (PMASS+0.15D0)**2
30150 XMINP2 = XMINP**2
30151C determine resonance probability
30152 DM2 = 1.1D0
30153 RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30154 IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30155C 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
30183C 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
30190C 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
30203C 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
30213C 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
30221CDECK ID>, PHO_PDF
30222 SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30223C***************************************************************
30224C
30225C call different PDF sets for different particle types
30226C
30227C input: NPAR 1 IGRP(1),ISET(1)
30228C 2 IGRP(2),ISET(2)
30229C X momentum fraction
30230C SCALE2 squared scale (GeV**2)
30231C P2VIR particle virtuality (positive, GeV**2)
30232C
30233C output PD(-6:6) field containing the x*PDF fractions
30234C
30235C***************************************************************
30236 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30237 SAVE
30238
30239 DIMENSION PD(-6:6)
30240
30241C input/output channels
30242 INTEGER LI,LO
30243 COMMON /POINOU/ LI,LO
30244C 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
30250C 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
30257C 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
30269C 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
30293C internal PDFs
30294
30295 IF(IEXT(NPAR).EQ.0) THEN
30296 IF(ITYPE(NPAR).EQ.1) THEN
30297C 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)
30313C 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)
30340C 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)
30367C 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
30396C 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
30425C 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
30464C 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
30486C 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
30498C 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
30523C 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
30543C external PDFs
30544
30545 ELSE IF(IEXT(NPAR).EQ.2) THEN
30546C 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
30570C 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
30574C 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
30580C 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
30587C 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
30596C photon PDFs depending on photon virtuality
30597
30598 ELSE IF(IEXT(NPAR).EQ.4) THEN
30599 IF(IGRP(NPAR).EQ.1) THEN
30600C 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
30611C 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
30632C 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
30640C 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
30647C valence quark treatment
30648
30649 IF(ITYPE(NPAR).EQ.2) THEN
30650C meson conventions
30651 IF(IPARID(NPAR).EQ.111) THEN
30652C 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
30658C 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
30665C 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
30676C nucleon conventions
30677 IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30678C 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
30683C (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
30688C (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
30697C (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
30708C 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
30717C 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
30725C 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
30734CDECK ID>, PHO_QPMPDF
30735 SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30736C***************************************************************
30737C
30738C contribution to photon PDF from box graph
30739C (Bethe-Heitler process)
30740C
30741C input: IQ quark flavour
30742C SCALE2 scale (GeV**2, positive)
30743C PTREF reference scale (GeV, positive)
30744C X parton momentum fraction
30745C PVIRT photon virtuality (GeV**2, positive)
30746C FXP x*f(x,Q**2), x times parton density
30747C
30748C***************************************************************
30749 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30750 SAVE
30751
30752C input/output channels
30753 INTEGER LI,LO
30754 COMMON /POINOU/ LI,LO
30755C 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
30762C internal rejection counters
30763 INTEGER NMXJ
30764 PARAMETER (NMXJ=60)
30765 CHARACTER*10 REJTIT
30766 INTEGER IFAIL
30767 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30768C 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)
30778C
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)
30789C 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
30807C 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
30812CDECK ID>, PHO_SETPDF
30813 SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
30814C***************************************************************
30815C
30816C assigns PDF numbers to particles
30817C
30818C input: IDPDG PDG number of particle
30819C ITYP particle type
30820C IPAR PDF paramertization
30821C ISET number of set
30822C IEXT library number for PDF calculation
30823C IPAVAL (only output)
30824C 1 PDF with valence quarks
30825C 0 PDF without valence quarks
30826C MODE -1 add entry to table
30827C 1 read from table
30828C 2 output of table
30829C
30830C***************************************************************
30831 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30832 SAVE
30833
30834C input/output channels
30835 INTEGER LI,LO
30836 COMMON /POINOU/ LI,LO
30837C 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
30844C 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
30865200 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
30925CDECK ID>, PHO_GETPDF
30926 SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
30927C***************************************************************
30928C
30929C get PDF information
30930C
30931C input: NPAR 1 first PDF in /POPPDF/
30932C 2 second PDF in /POPPDF/
30933C
30934C output: PDFNA name of PDf parametrization
30935C ALA QCD LAMBDA (4 flavours, in GeV)
30936C Q2MI minimal Q2
30937C Q2MA maximal Q2
30938C XMI minimal X
30939C XMA maximal X
30940C
30941C***************************************************************
30942 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30943 SAVE
30944
30945 CHARACTER*8 PDFNA
30946
30947C input/output channels
30948 INTEGER LI,LO
30949 COMMON /POINOU/ LI,LO
30950
30951C PHOLIB 4.15 common
30952 COMMON /W50512/ QCDL4,QCDL5
30953 COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
30954
30955C 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
30962C 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
30981C internal parametrizations
30982
30983 IF(ITYPE(NPAR).EQ.1) THEN
30984C 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
31017C 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
31030C 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
31053C 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
31063C external parametrizations
31064
31065 ELSE IF(IEXT(NPAR).EQ.1) THEN
31066C 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
31078C 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
31094C PHOLIB interface
31095 ALA = ALM(IGRP(NPAR),ISET(NPAR))
31096 Q2MI = 2.D0
31097 PDFNA = CHPAR(IGRP(NPAR))
31098
31099C some special internal parametrizations
31100
31101 ELSE IF(IEXT(NPAR).EQ.4) THEN
31102C photon PDFs depending on virtualities
31103 IF(IGRP(NPAR).EQ.1) THEN
31104C 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
31120C 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
31128C 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
31143CDECK ID>, PHO_ACTPDF
31144 SUBROUTINE PHO_ACTPDF(IDPDG,K)
31145C***************************************************************
31146C
31147C activate PDF for QCD calculations
31148C
31149C input: IDPDG PDG particle number
31150C K 1 first PDF in /POPPDF/
31151C 2 second PDF in /POPPDF/
31152C -2 write current settings
31153C
31154C output: /POPPDF/
31155C
31156C***************************************************************
31157 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31158 SAVE
31159
31160C input/output channels
31161 INTEGER LI,LO
31162 COMMON /POINOU/ LI,LO
31163C 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
31170C 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
31179C 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
31183C get PDF parameters
31184 CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31185C 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
31200C 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
31220CDECK ID>, PHO_PDFTST
31221 SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31222C*********************************************************************
31223C
31224C structure function test utility
31225C
31226C input: IDPDG PDG ID of particle
31227C SCALE2 squared scale (GeV**2)
31228C P2MASS particle virtuality (pos, GeV**2)
31229C
31230C output: tables of PDF, sum rule checking, table of F2
31231C
31232C*********************************************************************
31233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31234 SAVE
31235
31236C input/output channels
31237 INTEGER LI,LO
31238 COMMON /POINOU/ LI,LO
31239C 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
31245C 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
31269C logarithmic loop over x values
31270C upper bound
31271 XUPPER=0.9999D0
31272C lower bound
31273 XLOWER=1.D-4
31274C 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
31309C 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
31342C 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
31361CDECK ID>, PHO_REGPAR
31362 SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31363 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31364C**********************************************************************
31365C
31366C registration of particle in /POEVT1/ and /POEVT2/
31367C
31368C input: ISTH status code of particle
31369C -2 initial parton hard scattering
31370C -1 parton
31371C 0 string
31372C 1 visible particle (no color)
31373C 2 decayed particle
31374C IDPDG PDG particle ID code
31375C IDBAM CPC particle ID code
31376C JM1,JM2 first and second mother index
31377C P1..P4 four momentum
31378C IPHIS1 extended history information
31379C IPHIS1<100: JM1 from particle 1
31380C IPHIS1>100: JM1 from particle 2
31381C 1 valence quark
31382C 2 valence diquark
31383C 3 sea quark
31384C 4 sea diquark
31385C (neg. for antipartons)
31386C IPHIS2 extended history information
31387C positive: JM2 from particle 1
31388C negative: JM2 from particle 2
31389C (see IPHIS1)
31390C IC1,IC2 color labels for partons
31391C IMODE 1 register given parton
31392C 0 reset /POEVT1/ and /POEVT2/
31393C 2 return data of entry IPOS
31394C
31395C IPOS position of particle in /POEVT1/
31396C
31397C**********************************************************************
31398 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31399 SAVE
31400
31401 PARAMETER (DEPS = 1.D-20)
31402
31403C input/output channels
31404 INTEGER LI,LO
31405 COMMON /POINOU/ LI,LO
31406C 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
31414C 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)
31424C 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
31452C standard data
31453 ISTHEP(NHEP) = ISTH
31454 IDHEP(NHEP) = IDPDGI
31455 JMOHEP(1,NHEP) = JM1
31456 JMOHEP(2,NHEP) = JM2
31457C 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
31479100 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
31494C extended information
31495 IMPART(NHEP) = IDBAMI
31496C extended history information
31497 IPHIST(1,NHEP) = IPHIS1
31498 IPHIST(2,NHEP) = IPHIS2
31499C 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
31542CDECK ID>, IPHO_CNV1
31543 INTEGER FUNCTION IPHO_CNV1(IPART)
31544C*********************************************************************
31545C
31546C conversion of quark numbering scheme to PARTICLE DATA GROUP
31547C convention
31548C
31549C input: old internal particle code of hard scattering
31550C 0 gluon
31551C 1 d
31552C 2 u
31553C 3 s
31554C 4 c
31555C valence quarks changed to standard numbering
31556C
31557C output: standard particle codes
31558C
31559C*********************************************************************
31560 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31561 SAVE
31562C
31563 II = ABS(IPART)
31564C change gluon number
31565 IF(II.EQ.0) THEN
31566 IPHO_CNV1 = 21
31567C 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
31575CDECK ID>, PHO_HACODE
31576 SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31577C*********************************************************************
31578C
31579C determination of hadron index from quarks
31580C
31581C input: ID1,ID2 parton code according to PDG conventions
31582C
31583C output: IDcpc1,2 CPC particle codes
31584C
31585C*********************************************************************
31586
31587 IMPLICIT NONE
31588
31589 SAVE
31590
31591 integer ID1,ID2,IDcpc1,IDcpc2
31592
31593C input/output channels
31594 INTEGER LI,LO
31595 COMMON /POINOU/ LI,LO
31596C 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
31603C 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
31617C local variables
31618 integer ii,jj,kk,i1,i2
31619
31620 IDcpc1 = 0
31621 IDcpc2 = 0
31622
31623 if(ID1*ID2.lt.0) then
31624C 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
31636C 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
31655CDECK ID>, PHO_ID2STR
31656 SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31657C*********************************************************************
31658C
31659C conversion of quark numbering scheme
31660C
31661C input: standard particle codes:
31662C ID1
31663C ID2
31664C
31665C output: NOBAM CPC string code
31666C quark codes (PDG convention):
31667C IBAM1
31668C IBAM2
31669C IBAM3
31670C IBAM4
31671C
31672C NOBAM = -1 invalid flavour combinations
31673C
31674C*********************************************************************
31675 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31676 SAVE
31677
31678C input/output channels
31679 INTEGER LI,LO
31680 COMMON /POINOU/ LI,LO
31681
31682 IDA1 = ABS(ID1)
31683 IDA2 = ABS(ID2)
31684
31685C 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
31693C 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
31701C 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
31709C 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
31716C 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
31727C 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
31735CDECK ID>, PHO_MKSLTR
31736 SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31737C********************************************************************
31738C
31739C calculate successive Lorentz boots for arbitrary Lorentz trans.
31740C
31741C input: P1 initial 4 vector
31742C GAM(3),GAMB(3) Lorentz boost parameters
31743C
31744C output: P2 final 4 vector
31745C
31746C********************************************************************
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
31759CDECK ID>, PHO_GETLTR
31760 SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
31761C********************************************************************
31762C
31763C calculate Lorentz boots for arbitrary Lorentz transformation
31764C
31765C input: P1 initial 4 vector
31766C P2 final 4 vector
31767C
31768C output: GAM(3),GAMB(3)
31769C DELE energy deviation
31770C IREJ 0 success
31771C 1 failure
31772C
31773C********************************************************************
31774 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31775 SAVE
31776
31777 PARAMETER ( DREL = 0.001D0 )
31778
31779C 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
31806C 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
31818CDECK ID>, PHO_ALTRA
31819 SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
31820C*********************************************************************
31821C
31822C arbitrary Lorentz transformation
31823C
31824C*********************************************************************
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
31838CDECK ID>, PHO_LTRANS
31839 SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
31840 & PL,CXL,CYL,CZL,EL)
31841C**********************************************************************
31842C
31843C Lorentz transformation into lab - system
31844C
31845C**********************************************************************
31846 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31847 SAVE
31848
31849 PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
31850
31851C 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
31863C 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
31908CDECK ID>, PHO_TRANS
31909 SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31910C**********************************************************************
31911C
31912C rotation of coordinate frame (1) de rotation around y axis
31913C (2) fe rotation around z axis
31914C (inverse rotation to PHO_TRANI)
31915C
31916C**********************************************************************
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
31926CDECK ID>, PHO_TRANI
31927 SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31928C**********************************************************************
31929C
31930C rotation of coordinate frame (1) -fe rotation around z axis
31931C (2) -de rotation around y axis
31932C (inverse rotation to PHO_TRANS)
31933C
31934C**********************************************************************
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
31944CDECK ID>, pho_cpcini
31945 SUBROUTINE pho_cpcini(Nrows,Number,List)
31946C***********************************************************************
31947C
31948C initialization of particle hash table
31949C
31950C input: Number vector with Nrows entries according to PDG
31951C convention
31952C
31953C output: List vector with hash table
31954C
31955C (this code is based on the function initpns written by
31956C Gerry Lynch, LBL, January 1990)
31957C
31958C***********************************************************************
31959
31960 IMPLICIT NONE
31961
31962 SAVE
31963
31964C 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
31976C Loop over all of the elements in the Number vector
31977
31978 Do 500 Ip = 1,Nrows
31979 Nin = Number(Ip)
31980
31981C 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
31993C 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
32014CDECK ID>, ipho_pdg2id
32015 INTEGER FUNCTION ipho_pdg2id(IDpdg)
32016C**********************************************************************
32017C
32018C calculation internal particle code using the particle index i
32019C according to the PDG proposal.
32020C
32021C input: IDpdg PDG particle number
32022C output: ipho_pdg2id internal particle code
32023C (0 for invalid IDpdg)
32024C
32025C the hash algorithm is based on a program by Gerry Lynch
32026C
32027C**********************************************************************
32028
32029 IMPLICIT NONE
32030
32031 SAVE
32032
32033 integer IDpdg
32034
32035C input/output channels
32036 INTEGER LI,LO
32037 COMMON /POINOU/ LI,LO
32038C 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
32045C 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
d30b8254 32052 Nin = abs(IDpdg)
32053
32054 if((Nin.gt.99999).or.(Nin.eq.0)) then
32055C 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
32061C simple case
32062 Nout = Nin
32063 else
32064C use hash algorithm
32065 Nout = mod(Nin,577)
32066 endif
32067
32068 100 continue
32069
32070C 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
32079C particle ID found
32080 ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32081 return
32082 else
32083C 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
32091CDECK ID>, IPHO_ID2PDG
32092 INTEGER FUNCTION ipho_id2pdg(IDcpc)
32093C**********************************************************************
32094C
32095C conversion of internal particle code to PDG standard
32096C
32097C input: IDcpc internal particle number
32098C output: ipho_id2pdg PDG particle number
32099C (0 for invalid IDcpc)
32100C
32101C**********************************************************************
32102
32103 IMPLICIT NONE
32104
32105 SAVE
32106
32107 integer IDcpc
32108
32109C input/output channels
32110 INTEGER LI,LO
32111 COMMON /POINOU/ LI,LO
32112C 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
32119C 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
32137CDECK ID>, IPHO_LU2PDG
32138 INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32139C**********************************************************************
32140C
32141C conversion of JETSET KF code to PDG code
32142C
32143C**********************************************************************
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 /
32158C
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
32169CDECK ID>, IPHO_PDG2LU
32170 INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32171C**********************************************************************
32172C
32173C conversion of PDG code to JETSET code
32174C
32175C**********************************************************************
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 /
32188C
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
32199CDECK ID>, pho_pname
32200 CHARACTER*15 FUNCTION pho_pname(ID,mode)
32201C***********************************************************************
32202C
32203C returns particle name for given ID number
32204C
32205C input: ID particle ID number
32206C mode 0: ID treated as compressed particle code
32207C 1: ID treated as PDG number
32208C
32209C***********************************************************************
32210
32211 IMPLICIT NONE
32212
32213 SAVE
32214
32215 integer ID,mode
32216
32217C input/output channels
32218 INTEGER LI,LO
32219 COMMON /POINOU/ LI,LO
32220
32221C 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)
32231C 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
32235C 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
32240C 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
32254C external functions
32255 integer ipho_id2pdg,ipho_pdg2id
32256
32257C 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
32307C 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
32313C 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
32331C 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
32346CDECK ID>, ipho_anti
32347 INTEGER FUNCTION ipho_anti(ID)
32348C**********************************************************************
32349C
32350C determine antiparticle for given ID
32351C
32352C input: ID gives CPC particle number
32353C
32354C output: ipho_anti antiparticle code
32355C
32356C**********************************************************************
32357
32358 IMPLICIT NONE
32359
32360 SAVE
32361
32362 integer ID
32363
32364C input/output channels
32365 INTEGER LI,LO
32366 COMMON /POINOU/ LI,LO
32367C 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
32374C 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
32379C 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
32393C 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)
32403C 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
32407C external functions
32408 integer ipho_id2pdg,ipho_pdg2id
32409
32410C local variables
32411 integer IDabs,IDpdg,i_anti,l
32412
32413 ipho_anti = -ID
32414 IDabs = abs(ID)
32415
32416C baryons
32417 if(iba3_list(IDabs).ne.0) return
32418
32419C charged particles
32420 if(ich3_list(IDabs).ne.0) return
32421
32422C 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
32432C 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
32439C 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
32447CDECK ID>, ipho_chr3
32448 INTEGER FUNCTION ipho_chr3(ID,mode)
32449C**********************************************************************
32450C
32451C output of three times the electric charge
32452C
32453C input: mode
32454C 0 ID gives CPC particle number
32455C 1 ID gives PDG particle number
32456C 2 ID gives position of particle in /POEVT1/
32457C
32458C**********************************************************************
32459
32460 IMPLICIT NONE
32461
32462 SAVE
32463
32464 integer ID,mode
32465
32466C input/output channels
32467 INTEGER LI,LO
32468 COMMON /POINOU/ LI,LO
32469C 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
32477C 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)
32487C 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
32491C 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
32496C 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
32510C external functions
32511 integer ipho_pdg2id
32512
32513C 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
32550CDECK ID>, ipho_bar3
32551 INTEGER FUNCTION ipho_bar3(ID,mode)
32552C**********************************************************************
32553C
32554C output of three times the baryon charge
32555C
32556C index: MODE
32557C 0 ID gives CPC particle number
32558C 1 ID gives PDG particle number
32559C 2 ID gives position of particle in /POEVT1/
32560C
32561C**********************************************************************
32562
32563 IMPLICIT NONE
32564
32565 SAVE
32566
32567 integer ID,mode
32568
32569C input/output channels
32570 INTEGER LI,LO
32571 COMMON /POINOU/ LI,LO
32572C 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
32580C 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)
32590C 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
32594C 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
32599C 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
32613C external functions
32614 integer ipho_pdg2id
32615
32616C 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
32652CDECK ID>, pho_pmass
32653 DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32654C***********************************************************************
32655C
32656C particle mass
32657C
32658C input: mode -1 initialization
32659C 0 ID gives CPC particle number
32660C 1 ID gives PDG particle number,
32661C (for quarks current masses are returned)
32662C 2 ID gives position of particle in /POEVT1/
32663C 3 ID gives PDG parton number,
32664C (for quarks constituent masses are returned)
32665C
32666C output: average particle mass (in GeV)
32667C
32668C***********************************************************************
32669
32670 IMPLICIT NONE
32671
32672 SAVE
32673
32674 integer ID,mode,MSTJ24
32675
32676C input/output channels
32677 INTEGER LI,LO
32678 COMMON /POINOU/ LI,LO
32679C 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
32686C 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
32692C 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)
32702C 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
32706C 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
32711C 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
32729C external functions
32730 integer ipho_pdg2id,ipho_id2pdg
32731
32732 DOUBLE PRECISION PYMASS
32733
32734C 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
32762C 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
32790CDECK ID>, PHO_MEMASS
32791 SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
32792C**********************************************************************
32793C
32794C determine meson masses corresponding to the input flavours
32795C
32796C input: I,J,K quark flavours (PDG convention)
32797C
32798C output: AMPS pseudo scalar meson mass
32799C AMPS2 next possible two particle configuration
32800C (two pseudo scalar mesons)
32801C AMVE vector meson mass
32802C AMVE2 next possible two particle configuration
32803C (two vector mesons)
32804C IPS,IVE meson numbers in CPC
32805C
32806C**********************************************************************
32807
32808 IMPLICIT NONE
32809
32810 SAVE
32811
32812 integer I,J,IPS,IVE
32813 double precision AMPS,AMPS2,AMVE,AMVE2
32814
32815C input/output channels
32816 INTEGER LI,LO
32817 COMMON /POINOU/ LI,LO
32818C 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
32825C 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
32830C 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
32844C 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
32855C particle ID's
32856 IPS = id_psm_list(ii,jj)
32857 IVE = id_vem_list(ii,jj)
32858C 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
32870C 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
32876CDECK ID>, PHO_BAMASS
32877 SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
32878C**********************************************************************
32879C
32880C determine baryon masses corresponding to the input flavours
32881C
32882C input: I,J,K quark flavours (PDG convention)
32883C
32884C output: AM8 octett baryon mass
32885C AM82 next possible two particle configuration
32886C (octett baryon and meson)
32887C AM10 decuplett baryon mass
32888C AM102 next possible two particle configuration
32889C (decuplett baryon and meson,
32890C baryon built up from first two quarks)
32891C I8,I10 internal baryon numbers
32892C
32893C**********************************************************************
32894
32895 IMPLICIT NONE
32896
32897 SAVE
32898
32899 integer I,J,K,I8,I10
32900 double precision AM8,AM82,AM10,AM102
32901
32902C input/output channels
32903 INTEGER LI,LO
32904 COMMON /POINOU/ LI,LO
32905C 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
32912C 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
32917C 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
32931C local variables
32932 integer ii,jj,kk
32933
32934C 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
32941C 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
32955C 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
32961CDECK ID>, PHO_DQMASS
32962 SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
32963C**********************************************************************
32964C
32965C determine minimal masses corresponding to the input flavours
32966C (diquark a-diquark string system)
32967C
32968C input: I,J,K,L quark flavours (PDG convention)
32969C
32970C output: AM82 mass of two octett baryons
32971C AM102 mass of two decuplett baryons
32972C
32973C**********************************************************************
32974
32975 IMPLICIT NONE
32976
32977 SAVE
32978
32979 integer I,J,K,L
32980 double precision AM82,AM102
32981
32982C input/output channels
32983 INTEGER LI,LO
32984 COMMON /POINOU/ LI,LO
32985C 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
32992C 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
33006C 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
33019CDECK ID>, PHO_CHECK
33020 SUBROUTINE PHO_CHECK(MD,IDEV)
33021C**********************************************************************
33022C
33023C check quantum numbers of entries in /POEVT1/ and /POEVT2/
33024C (energy, momentum, charge, baryon number conservation)
33025C
33026C input: MD -1 check overall momentum conservation
33027C and perform detailed check only in case of
33028C deviations
33029C 1 test all branchings, mother-daughter
33030C relations
33031C
33032C output: IDEV 0 no deviations
33033C 1 deviations found
33034C
33035C**********************************************************************
33036 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33037 SAVE
33038
33039C input/output channels
33040 INTEGER LI,LO
33041 COMMON /POINOU/ LI,LO
33042C 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
33049C 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)
33054C 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)
33058C 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
33064C 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)
33074C 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
33078C 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
33086C count number of errors to avoid disk overflow
33087 DATA IERR / 0 /
33088
33089 IDEV = 0
33090C conservation check suppressed
33091 IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33092
33093 IF(IPAMDL(13).GT.0) THEN
33094
33095C DPMJET call with x limitations
33096 MODE = -1
33097 ECM1 = SQRT(XPSUB*XTSUB)*ECM
33098
33099 ELSE
33100
33101C standard call
33102 MODE = MD
33103C 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
33120C recognize only decayed particles as mothers
33121 IF(ISTHEP(I).EQ.2) THEN
33122C 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)
33132C 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
33165C 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
33183C 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
33243C 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
33254C 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
33263C 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
33275C 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
33286C check energy-momentum conservation
33287 ESC = ECM*DDREL
33288
33289 IF(IPAMDL(13).GT.0) THEN
33290
33291C 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
33302C 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
33328C 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
33348C 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
33363CDECK ID>, PHO_ABORT
33364 SUBROUTINE PHO_ABORT
33365C**********************************************************************
33366C
33367C top MC event generation due to fatal error,
33368C print all information of event generation and history
33369C
33370C**********************************************************************
33371 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33372 SAVE
33373
33374C input/output channels
33375 INTEGER LI,LO
33376 COMMON /POINOU/ LI,LO
33377C 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
33384C 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
33390C 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)
33400C 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
33404C 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
33411C 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)
33419C 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:'
33437C
33438 CALL PHO_SETMDL(0,0,-2)
33439 CALL PHO_PREVNT(-1)
33440 CALL PHO_ACTPDF(0,-2)
33441C 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
33453C 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
33467C print /POEVT1/
33468 CALL PHO_PREVNT(0)
33469
33470C fragmentation process
33471 IF(ISTR.GT.0) THEN
33472C print /POSTRG/
33473 CALL PHO_PRSTRG
33474
33475 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33476
33477 ENDIF
33478
33479C 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
33487CDECK ID>, PHO_TRACE
33488 SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33489C**********************************************************************
33490C
33491C trace program subroutines according to level,
33492C original output levels will be saved
33493C
33494C input: ISTART first event to trace
33495C ISWI number of events to trace
33496C 0 loop call, use old values
33497C -1 restore original output levels
33498C 1 store level and wait for event
33499C LEVEL desired output level
33500C 0 standard output
33501C 3 internal rejections
33502C 5 cross sections, slopes etc.
33503C 10 parameter of subroutines and
33504C results
33505C 20 huge amount of debug output
33506C 30 maximal possible output
33507C
33508C**********************************************************************
33509 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33510 SAVE
33511
33512C input/output channels
33513 INTEGER LI,LO
33514 COMMON /POINOU/ LI,LO
33515C 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
33525C 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
33550C save information
33551 ION = ISTART
33552 IOFF = ISTART+ISW
33553 ILEVEL = LEVEL
33554 ENDIF
33555C check coincidence
33556 IF(ISW.GT.0) THEN
33557 ISW=0
33558 ILEVEL = LEVEL
33559 GOTO 10
33560 ENDIF
33561
33562 END
33563
33564CDECK ID>, PHO_PRSTRG
33565 SUBROUTINE PHO_PRSTRG
33566C**********************************************************************
33567C
33568C print information of /POSTRG/
33569C
33570C**********************************************************************
33571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33572 SAVE
33573
33574C input/output channels
33575 INTEGER LI,LO
33576 COMMON /POINOU/ LI,LO
33577C 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
33585C 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)
33595C 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
33599C 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
33621CDECK ID>, PHO_PREVNT
33622 SUBROUTINE PHO_PREVNT(NPART)
33623C**********************************************************************
33624C
33625C print all information of event generation and history
33626C
33627C input: NPART -1 minimal output: process IDs
33628C 0 additional output of /POEVT1/
33629C 1 additional output of /POSTRG/
33630C 2 additional output of /HEPEVT/
33631C (call LULIST(1))
33632C
33633C**********************************************************************
33634 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33635 SAVE
33636
33637C input/output channels
33638 INTEGER LI,LO
33639 COMMON /POINOU/ LI,LO
33640C 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
33647C 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)
33652C 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)
33656C general process information
33657 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33658 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33659
33660C 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)
33670C 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
33674C 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
33784CDECK ID>, PHO_LTRHEP
33785 SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
33786C*******************************************************************
33787C
33788C Lorentz transformation of entries I1 to I2 in /POEVT1/
33789C
33790C********************************************************************
33791 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33792 SAVE
33793
33794 PARAMETER ( DIFF = 0.001D0,
33795 & EPS = 1.D-5 )
33796
33797C input/output channels
33798 INTEGER LI,LO
33799 COMMON /POINOU/ LI,LO
33800C 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
33808C 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)
33818C 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
33838C 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
33853CDECK ID>, PHO_PECMS
33854 SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
33855C*******************************************************************
33856C
33857C calculation of cms momentum and energy of massive particle
33858C (ID= 1 using PMASS1, 2 using PMASS2)
33859C
33860C output: PP cms momentum
33861C EE energy in CMS of particle ID
33862C
33863C********************************************************************
33864 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33865 SAVE
33866
33867C input/output channels
33868 INTEGER LI,LO
33869 COMMON /POINOU/ LI,LO
33870C 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
33877C 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
33900CDECK ID>, PHO_FRAINI
33901 SUBROUTINE PHO_FRAINI(IDEFAU)
33902C***********************************************************************
33903C
33904C initialization of fragmentation packages
33905C (currently LUND JETSET)
33906C
33907C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
33908C changed to work in PHOJET (R.E. 1/94)
33909C
33910C input: IDEFAU 0 no hadronization at all
33911C 1 do not touch any parameter of JETSET
33912C 2 default parameters kept, decay length 10mm to
33913C define stable particles
33914C 3 load tuned parameters for JETSET 7.3
33915C neg. value: prevent strange/charm hadrons from decaying
33916C
33917C***********************************************************************
33918 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33919 SAVE
33920
33921 PARAMETER (EPS=1.D-10)
33922
33923C 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
33951C 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
33959C declare stable particles
33960 IF(IDEFAB.GE.2) MSTJ(22) = 2
33961
33962C load optimized parameters
33963 IF(IDEFAB.GE.3) THEN
33964
33965* PARJ(19)=0.19
33966C Lund a-parameter
33967C (default=0.3)
33968 PARJ(41)=0.3
33969C Lund b-parameter
33970C (default=1.0)
33971 PARJ(42)=1.0
33972C Lund sigma parameter in pt distribution
33973C (default=0.36)
33974 PARJ(21)=0.36
33975 ENDIF
33976C
33977C prevent particles decaying
33978 IF(IDEFAU.LT.0) THEN
33979C K0S
33980
33981 KC=PYCOMP(310)
33982
33983 MDCY(KC,1)=0
33984C PI0
33985
33986 KC=PYCOMP(111)
33987
33988 MDCY(KC,1)=0
33989C LAMBDA
33990
33991 KC=PYCOMP(3122)
33992
33993 MDCY(KC,1)=0
33994C ALAMBDA
33995
33996 KC=PYCOMP(-3122)
33997
33998 MDCY(KC,1)=0
33999C SIG+
34000
34001 KC=PYCOMP(3222)
34002
34003 MDCY(KC,1)=0
34004C ASIG+
34005
34006 KC=PYCOMP(-3222)
34007
34008 MDCY(KC,1)=0
34009C SIG-
34010
34011 KC=PYCOMP(3112)
34012
34013 MDCY(KC,1)=0
34014C ASIG-
34015
34016 KC=PYCOMP(-3112)
34017
34018 MDCY(KC,1)=0
34019C SIG0
34020
34021 KC=PYCOMP(3212)
34022
34023 MDCY(KC,1)=0
34024C ASIG0
34025
34026 KC=PYCOMP(-3212)
34027
34028 MDCY(KC,1)=0
34029C TET0
34030
34031 KC=PYCOMP(3322)
34032
34033 MDCY(KC,1)=0
34034C ATET0
34035
34036 KC=PYCOMP(-3322)
34037
34038 MDCY(KC,1)=0
34039C TET-
34040
34041 KC=PYCOMP(3312)
34042
34043 MDCY(KC,1)=0
34044C ATET-
34045
34046 KC=PYCOMP(-3312)
34047
34048 MDCY(KC,1)=0
34049C OMEGA-
34050
34051 KC=PYCOMP(3334)
34052
34053 MDCY(KC,1)=0
34054C AOMEGA-
34055
34056 KC=PYCOMP(-3334)
34057
34058 MDCY(KC,1)=0
34059C D+
34060
34061 KC=PYCOMP(411)
34062
34063 MDCY(KC,1)=0
34064C D-
34065
34066 KC=PYCOMP(-411)
34067
34068 MDCY(KC,1)=0
34069C D0
34070
34071 KC=PYCOMP(421)
34072
34073 MDCY(KC,1)=0
34074C A-D0
34075
34076 KC=PYCOMP(-421)
34077
34078 MDCY(KC,1)=0
34079C DS+
34080
34081 KC=PYCOMP(431)
34082
34083 MDCY(KC,1)=0
34084C A-DS+
34085
34086 KC=PYCOMP(-431)
34087
34088 MDCY(KC,1)=0
34089C ETAC
34090
34091 KC=PYCOMP(441)
34092
34093 MDCY(KC,1)=0
34094C LAMBDAC+
34095
34096 KC=PYCOMP(4122)
34097
34098 MDCY(KC,1)=0
34099C A-LAMBDAC+
34100
34101 KC=PYCOMP(-4122)
34102
34103 MDCY(KC,1)=0
34104C SIGMAC++
34105
34106 KC=PYCOMP(4222)
34107
34108 MDCY(KC,1)=0
34109C SIGMAC+
34110
34111 KC=PYCOMP(4212)
34112
34113 MDCY(KC,1)=0
34114C SIGMAC0
34115
34116 KC=PYCOMP(4112)
34117
34118 MDCY(KC,1)=0
34119C A-SIGMAC++
34120
34121 KC=PYCOMP(-4222)
34122
34123 MDCY(KC,1)=0
34124C A-SIGMAC+
34125
34126 KC=PYCOMP(-4212)
34127
34128 MDCY(KC,1)=0
34129C A-SIGMAC0
34130
34131 KC=PYCOMP(-4112)
34132
34133 MDCY(KC,1)=0
34134C KSIC+
34135
34136 KC=PYCOMP(4232)
34137
34138 MDCY(KC,1)=0
34139C KSIC0
34140
34141 KC=PYCOMP(4132)
34142
34143 MDCY(KC,1)=0
34144C A-KSIC+
34145
34146 KC=PYCOMP(-4232)
34147
34148 MDCY(KC,1)=0
34149C A-KSIC0
34150
34151 KC=PYCOMP(-4132)
34152
34153 MDCY(KC,1)=0
34154 ENDIF
34155
34156C *** Commented by Chiara
34157C WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34158C & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34159C 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34160C & ' --------------------------------------------------',/,
34161C & 5X,'parameter description default / current',/,
34162C & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34163C & 5X,'MSTJ(12) popcorn : ',2I7,/,
34164C & 5X,'PARJ(19) popcorn : ',2F7.3,/,
34165C & 5X,'PARJ(41) Lund a : ',2F7.3,/,
34166C & 5X,'PARJ(42) Lund b : ',2F7.3,/,
34167C & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34168
34169 END
34170
34171CDECK ID>, PHO_SETPAR
34172 SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34173C**********************************************************************
34174C
34175C assign a particle to either side 1 or 2
34176C (including special treatment for remnants)
34177C
34178C input: Iside 1,2 side selected for the particle
34179C -2 output of current settings
34180C IDpdg PDG number
34181C IDcpc CPC number
34182C 0 CPC determination in subroutine
34183C -1 special particle remnant, IDPDG
34184C is the particle number the remnant
34185C corresponds to (see /POHDFL/)
34186C
34187C**********************************************************************
34188
34189 IMPLICIT NONE
34190
34191 SAVE
34192
34193 integer Iside,IDpdg,IDcpc
34194 double precision Pvir
34195
34196C input/output channels
34197 INTEGER LI,LO
34198 COMMON /POINOU/ LI,LO
34199C 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
34206C 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)
34210C 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)
34215C 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
34220C 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)
34233C 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
34239C external functions
34240 integer ipho_pdg2id,ipho_chr3,ipho_bar3
34241 double precision pho_pmass
34242
34243C 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
34248C 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
34258C 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
34270C 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
34298C 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
34306C 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
34317C 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
34336CDECK ID>, PHO_XLAM
34337 DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34338C**********************************************************************
34339C
34340C auxiliary function for two/three particle decay mode
34341C (standard LAMBDA**(1/2) function)
34342C
34343C**********************************************************************
34344 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34345 SAVE
34346C
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
34353CDECK ID>, PHO_BESSJ0
34354 DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34355C**********************************************************************
34356C
34357C CERN (KERN) LIB function C312
34358C
34359C modified by R. Engel (03/02/93)
34360C
34361C**********************************************************************
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
34448CDECK ID>, PHO_BESSI0
34449 DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34450C**********************************************************************
34451C
34452C Bessel Function I0
34453C
34454C**********************************************************************
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
34475CDECK ID>, PHO_BESSI1
34476 DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34477C**********************************************************************
34478C
34479C Bessel Function I1
34480C
34481C**********************************************************************
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
34508CDECK ID>, PHO_BESSK0
34509 DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34510C**********************************************************************
34511C
34512C Modified Bessel Function K0
34513C
34514C**********************************************************************
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
34534CDECK ID>, PHO_BESSK1
34535 DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34536C**********************************************************************
34537C
34538C Modified Bessel Function K1
34539C
34540C**********************************************************************
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
34560CDECK ID>, PHO_GAUSET
34561 SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34562C********************************************************************
34563C
34564C N-point gauss zeros and weights for the interval (AX,BX) are
34565C stored in arrays Z and W respectively.
34566C
34567C*********************************************************************
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
34578C the N=1 case:
34579 IF(N.NE.1) GO TO 1
34580 Z(1)=ALPHA
34581 W(1)=BX-AX
34582 RETURN
34583
34584C 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
34595C the extended Gauss cases:
34596 IF((N/96)*96.EQ.N) GO TO 3
34597
34598C jump to center of intervall intrgration:
34599 GO TO 100
34600
34601C get Gauss point array
34602
34603 2 CALL PHO_GAUDAT
34604C extract real points
34605 K=KTAB(N)
34606 M=N/2
34607 DO 21 J=1,M
34608C extract values from big array
34609 JTAB=K-1+J
34610 WTEMP=BETA*A(JTAB)
34611 DELTA=BETA*X(JTAB)
34612C store them backward
34613 Z(J)=ALPHA-DELTA
34614 W(J)=WTEMP
34615C store them forward
34616 JP=N+1-J
34617 Z(JP)=ALPHA+DELTA
34618 W(JP)=WTEMP
34619 21 CONTINUE
34620C 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
34627C get ND96 times chained 96 Gauss point array
34628
34629 3 CALL PHO_GAUDAT
34630C print out message
34631C -extract real points
34632 K=KTAB(96)
34633 ND96=N/96
34634 DO 31 J=1,48
34635C 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)
34643C store them backward
34644 Z(J+JD96*96)=ZCNTR-DELTA
34645 W(J+JD96*96)=WTEMP
34646C 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
34654C the center of intervall cases:
34655 100 CONTINUE
34656C 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
34665CDECK ID>, PHO_GAUDAT
34666 SUBROUTINE PHO_GAUDAT
34667C*********************************************************************
34668C
34669C store big arrays needed for Gauss integral, CERNLIB D106BD
34670C (arrays A,X,ITAB copied on B,Y,LTAB)
34671C
34672C*********************************************************************
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
34679C-----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/
34715C
34716C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
34717C
34718C-----N=2
34719 DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
34720C-----N=3
34721 DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
34722 DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
34723C-----N=4
34724 DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
34725 DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
34726C-----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 /
34730C-----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 /
34734C-----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 /
34739C-----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 /
34744C-----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 /
34750C-----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 /
34756C-----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 /
34763C-----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 /
34770C-----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 /
34778C-----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 /
34786C-----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 /
34795C-----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 /
34804C-----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 /
34815C-----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 /
34828C-----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/
34845C-----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/
34866C-----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/
34891C-----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/
34924C-----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/
34965C-----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
35026CDECK ID>, PHO_DZEROX
35027 DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
35028C**********************************************************************
35029C
35030C Based on
35031C
35032C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
35033C Guaranteed Convergence for Finding a Zero of a Function,
35034C ACM Trans. Math. Software 1 (1975) 330-345.
35035C
35036C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
35037C
35038C CERNLIB C200
35039C
35040C***********************************************************************
35041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35042 SAVE
35043
35044C 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
35147CDECK ID>, PHO_EXPINT
35148 DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35149C***********************************************************************
35150C
35151C function to calculate E_i(x) = -E_1(-x)
35152C
35153C based on CERNLIB C337 (changed by R.Engel 10/1993)
35154C
35155C***********************************************************************
35156 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35157 SAVE
35158
35159C 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/
35233C
35234C conversion to E_i function
35235 X = -RXM
35236C
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
35303C sign conversion to E_i
35304 PHO_EXPINT=-Y
35305
35306 END
35307
35308CDECK ID>, PHO_RNDBET
35309 DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35310C********************************************************************
35311C
35312C RANDOM NUMBER GENERATION FROM BETA
35313C DISTRIBUTION IN REGION 0 < X < 1.
35314C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35315C *GAMM(ETA))
35316C
35317C********************************************************************
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
35328CDECK ID>, PHO_RNDGAM
35329 DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35330C********************************************************************
35331C
35332C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35333C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35334C
35335C********************************************************************
35336 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35337 SAVE
35338C
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
35365CDECK ID>, PHO_SFECFE
35366 SUBROUTINE PHO_SFECFE(SFE,CFE)
35367C**********************************************************************
35368C
35369C fast random SIN(X) COS(X) selection
35370C
35371C**********************************************************************
35372 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35373 SAVE
35374C
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
35389CDECK ID>, PHO_SWAPD
35390 SUBROUTINE PHO_SWAPD(D1,D2)
35391C********************************************************************
35392C
35393C exchange of argument values (double precision)
35394C
35395C********************************************************************
35396 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35397 D = D1
35398 D1 = D2
35399 D2 = D
35400 END
35401
35402CDECK ID>, PHO_SWAPI
35403 SUBROUTINE PHO_SWAPI(I1,I2)
35404C********************************************************************
35405C
35406C exchange of argument values (integer)
35407C
35408C********************************************************************
35409 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35410 K = I1
35411 I1 = I2
35412 I2 = K
35413 END
35414
35415CDECK ID>, PHO_HADCSL
35416 SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35417 & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35418C***********************************************************************
35419C
35420C low-energy cross section parametrizations
35421C
35422C input: ID1,ID2 PDG IDs of particles (meson first)
35423C ECM c.m. energy (GeV)
35424C PLAB lab. momentum (second particle at rest)
35425C IMODE 1 ECM given, PLAB ignored
35426C 2 PLAB given, ECM ignored
35427C
35428C output: SIGTOT total cross section (mb)
35429C SIGEL elastic cross section (mb)
35430C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
35431C SLOPE forward elastic slope (GeV**-2)
35432C RHO real/imaginary part of elastic amplitude
35433C
35434C comments:
35435C
35436C - low-energy data interpolation uses PDG fits from 1992 issue
35437C - high-energy extrapolation by Donnachie-Landshoff like fit made
35438C by PDG 1996
35439C - analytic extension of amplitude to calculate rho
35440C
35441C***********************************************************************
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
35450C input/output channels
35451 INTEGER LI,LO
35452 COMMON /POINOU/ LI,LO
35453C 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)
35457C 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
35508C 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
35527C 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
35542C 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
35554C 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
35576C 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
35594CDECK ID>, PHO_CSDIFF
35595 SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35596 & sig_sd1,sig_sd2,sig_dd)
35597C***********************************************************************
35598C
35599C cross section for diffraction dissociation according to
35600C Goulianos' parametrization (Ref: PL B358 (1995) 379)
35601C
35602C in addition rescaling for different particles is applied using
35603C internal rescaling tables (not implemented yet)
35604C
35605C input: Id1/2 PDG ID's of incoming particles
35606C SS squared c.m. energy (GeV**2)
35607C Xi_min min. diff mass (squared) = Xi_min*SS
35608C Xi_max max. diff mass (squared) = Xi_max*SS
35609C
35610C output: sig_sd1 cross section for diss. of particle 1 (mb)
35611C sig_sd2 cross section for diss. of particle 2 (mb)
35612C sig_dd cross section for diss. of both particles
35613C
35614C***********************************************************************
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
35623C input/output channels
35624 INTEGER LI,LO
35625 COMMON /POINOU/ LI,LO
35626C 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
35638C 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
35647C 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
35666C 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
35709C 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
35746C 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
35798CDECK ID>, PHO_ALLM97
35799 DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
35800C**********************************************************************
35801C
35802C ALLM97 parametrization for gamma*-p cross section
35803C (for F2 see comments, code adapted from V. Shekelyan, H1)
35804C
35805C**********************************************************************
35806
35807 IMPLICIT NONE
35808
35809 SAVE
35810
35811C 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
35826C 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
35838C 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
35849C
35850 M02 = 0.31985D0
35851 LAM2 = 0.065270D0
35852 Q02 = 0.46017D0 +LAM2
35853
35854C
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
35865C 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
35875C 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
35887C 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
35899C 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
35918CDECK ID>, PHO_DOR98LO
35919 SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
35920C***********************************************************************
35921C
35922C GRV98 parton densities, leading order set
35923C
35924C For a detailed explanation see
35925C M. Glueck, E. Reya, A. Vogt :
35926C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
35927C (To appear in Eur. Phys. J. C)
35928C
35929C interpolation routine based on the original GRV98PA routine,
35930C adapted to define interpolation table as DATA statements
35931C
35932C (R.Engel, 09/98)
35933C
35934C
35935C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
35936C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
35937C
35938C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
35939C DS = d(bar), SS = s = s(bar), GL = gluon.
35940C Always x times the distribution is returned.
35941C
35942C******************************************************i****************
35943 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
35944 SAVE
35945
35946C 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
37962CDECK ID>, PHO_DOR98SC
37963 SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
37964C***********************************************************************
37965C
37966C GRV98 parton densities, leading order set
37967C
37968C For a detailed explanation see
37969C M. Glueck, E. Reya, A. Vogt :
37970C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
37971C (To appear in Eur. Phys. J. C)
37972C
37973C interpolation routine based on the original GRV98PA routine,
37974C adapted to define interpolation table as DATA statements
37975C
37976C (R.Engel, 09/98)
37977C
37978C CAUTION: this is a version with gluon shadowing corrections
37979C (R.Engel, 09/99)
37980C
37981C
37982C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
37983C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
37984C
37985C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
37986C DS = d(bar), SS = s = s(bar), GL = gluon.
37987C Always x times the distribution is returned.
37988C
37989C******************************************************i****************
37990 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
37991 SAVE
37992
37993C 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 ##############
38013C ... 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
38053CDECK 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*
38183CDECK 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
38258CDECK 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*
38339CDECK 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
38349CDECK 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
38361CDECK 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
38373CDECK 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* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38401C
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
38411C...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)
38418C...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)
38425C...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)
38437C...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)
38449C...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)
38460C...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)
38471C...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
38485CDECK 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
38496C...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)
38503C...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)
38510C...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)
38522C...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)
38534C...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)
38545C...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)
38556C...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
38570CDECK 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
38579CDECK 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
38590CDECK 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
38606CDECK 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* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38633C
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
38643C...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)
38649C...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)
38661C...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)
38672C...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)
38683C...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
38697CDECK 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
38707C...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)
38713C...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)
38725C...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)
38736C...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)
38747C...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
38761CDECK 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
38771CDECK 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
38784CDECK 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
38800CDECK 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* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38827C
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
38837C...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)
38849C...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)
38861C...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)
38873C...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)
38886C...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)
38899C...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
38915CDECK 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
38925C...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)
38937C...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)
38949C...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)
38961C...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)
38974C...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)
38987C...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
39003CDECK 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
39013C...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)
39025C...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)
39037C...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)
39049C...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)
39062C...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)
39075C...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
39091CDECK 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
39104CDECK 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
39122CDECK 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
39165C input/output channels
39166 INTEGER LI,LO
39167 COMMON /POINOU/ LI,LO
39168
39169 integer check
39170c
39171c check limits :
39172c
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
39177c
39178c calculate distributions
39179c
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
39189CDECK 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
39198c
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/
39243c
39244 mu2=0.25d0
39245 lam2=0.232d0*0.232d0
39246c
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
39256c
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)
39278c
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)
39300c
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)
39322c
39323 s=log(log(q2/lam2)/log(mu2/lam2))
39324 suppr=1.d0/(1.d0+p2/0.59d0)**2
39325c
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)
39337c
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)
39349c
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)
39361c
39362 ugam=upart1+udpart2
39363 dgam=dspart1+udpart2
39364 sgam=dspart1+spart2
39365 ggam=gpart1+gpart2
39366c
39367 end
39368
39369CDECK 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
39381CDECK 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
39393CDECK ID>, PHO_CKMTPA
39394 SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39395C**********************************************************************
39396C
39397C PDF based on Regge theory, evolved with .... by ....
39398C
39399C input: IPAR 2212 proton (not installed)
39400C 990 Pomeron
39401C
39402C output: parameters of parametrization
39403C
39404C**********************************************************************
39405 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39406 SAVE
39407
39408 CHARACTER*8 PDFNA
39409
39410C 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
39453CDECK ID>, PHO_CKMTPD
39454 SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39455C**********************************************************************
39456C
39457C PDF based on Regge theory, evolved with .... by ....
39458C
39459C input: IPAR 2212 proton (not installed)
39460C 990 Pomeron
39461C
39462C output: PD(-6:6) x*f(x) parton distribution functions
39463C (PDFLIB convention: d = PD(1), u = PD(2) )
39464C
39465C**********************************************************************
39466 SAVE
39467
39468C 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)
39478C QCD lambda for evolution
39479 OWLAM = 0.23D0
39480 OWLAM2=OWLAM**2
39481C Q0**2 for evolution
39482 Q02 = 2.D0
39483C
39484C
39485C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39486C q(6)=x*charm, q(7)=x*gluon
39487C
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
39499C
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
39523CDECK ID>, PHO_CKMTPO
39524 SUBROUTINE PHO_CKMTPO(X,S,QQ)
39525C**********************************************************************
39526C
39527C calculation partons in Pomeron
39528C
39529C**********************************************************************
39530 SAVE
39531
39532 DIMENSION QQ(7)
39533
39534C 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
39542C RNG= -.5
39543C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
39544C 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
40419CDECK ID>, PHO_CKMTFV
40420 REAL FUNCTION PHO_CKMTFV(X,FVL)
40421C**********************************************************************
40422C
40423C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40424C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40425C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40426C IN MAIN ROUTINE.
40427C
40428C**********************************************************************
40429 SAVE
40430
40431 DIMENSION FVL(25),XGRID(25)
40432
40433C 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
40468C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40469C WRITE(LO,2001) X,FVL
40470C 2001 FORMAT(8E12.4)
40471C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40472C ENDIF
40473 PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40474
40475 END
40476
40477CDECK ID>, PHO_SASGAM
40478C***********************************************************************
40479C...SaSgam version 2 - parton distributions of the photon
40480C...by Gerhard A. Schuler and Torbjorn Sjostrand
40481C...For further information see Z. Phys. C68 (1995) 607
40482C...and Phys. Lett. B376 (1996) 193.
40483
40484C...18 January 1996: original code.
40485C...22 July 1996: calculation of BETA moved in SASBEH.
40486
40487C!!!Note that one further call parameter - IP2 - has been added
40488C!!!to the SASGAM argument list compared with version 1.
40489
40490C...The user should only need to call the SASGAM routine,
40491C...which in turn calls the auxiliary routines SASVMD, SASANO,
40492C...SASBEH and SASDIR. The package is self-contained.
40493
40494C...One particular aspect of these parametrizations is that F2 for
40495C...the photon is not obtained just as the charge-squared-weighted
40496C...sum of quark distributions, but differ in the treatment of
40497C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40498C...the kinematics range of heavy-flavour production, but the same
40499C...kinematics is not relevant e.g. for jet production) and, for the
40500C...'MSbar' fits, in the addition of a Cgamma term related to the
40501C...separation of direct processes. Schematically:
40502C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40503C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
40504C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40505C...The J/psi and Upsilon states have not been included in the VMD sum,
40506C...but low c and b masses in the other components should compensate
40507C...for this in a duality sense.
40508
40509C...The calling sequence is the following:
40510C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40511C...with the following declaration statement:
40512C DIMENSION XPDFGM(-6:6)
40513C...and, optionally, further information in:
40514C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40515C &XPDIR(-6:6)
40516C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40517C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
40518C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40519C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
40520C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
40521C X : x value.
40522C Q2 : Q2 value.
40523C P2 : P2 value; should be = 0. for an on-shell photon.
40524C IP2 : scheme used to evaluate off-shell anomalous component.
40525C = 0 : recommended default, see = 7.
40526C = 1 : dipole dampening by integration; very time-consuming.
40527C = 2 : P_0^2 = max( Q_0^2, P^2 )
40528C = 3 : P_0^2 = Q_0^2 + P^2.
40529C = 4 : P_{eff} that preserves momentum sum.
40530C = 5 : P_{int} that preserves momentum and average
40531C evolution range.
40532C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40533C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40534C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40535C XPFDGM : x times parton distribution functions of the photon,
40536C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40537C 6 = t (always empty!), - for antiquarks (result is same).
40538C...The breakdown by component is stored in the commonblock SASCOM,
40539C with elements as above.
40540C XPVMD : rho, omega, phi VMD part only of output.
40541C XPANL : d, u, s anomalous part only of output.
40542C XPANH : c, b anomalous part only of output.
40543C XPBEH : c, b Bethe-Heitler part only of output.
40544C XPDIR : Cgamma (direct contribution) part only of output.
40545C...The above arrays do not distinguish valence and sea contributions,
40546C...although this information is available internally. The additional
40547C...commonblock SASVAL provides the valence part only of the above
40548C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40549C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40550C...and therefore not given doubly. VXPDGM gives the sum of valence
40551C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40552C...and so on, gives the sea part only.
40553C***********************************************************************
40554
40555 SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40556C...Purpose: to construct the F2 and parton distributions of the photon
40557C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40558C...For F2, c and b are included by the Bethe-Heitler formula;
40559C...in the 'MSbar' scheme additionally a Cgamma term is added.
40560 SAVE
40561 DIMENSION XPDFGM(-6:6)
40562
40563C 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
40572C...Temporary array.
40573 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40574C...Charm and bottom masses (low to compensate for J/psi etc.).
40575 DATA PMC/1.3/, PMB/4.6/
40576C...alpha_em and alpha_em/(2*pi).
40577 DATA AEM/0.007297/, AEM2PI/0.0011614/
40578C...Lambda value for 4 flavours.
40579 DATA ALAM/0.20/
40580C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40581 DATA FRACU/0.8/
40582C...VMD couplings f_V**2/(4*pi).
40583 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40584C...Masses for rho (=omega) and phi.
40585 DATA PMRHO/0.770/, PMPHI/1.020/
40586C...Number of points in integration for IP2=1.
40587 DATA NSTEP/100/
40588
40589C...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
40604C...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
40616C...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
40624C...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
40658C...Call VMD parametrization for d quark and use to give rho, omega,
40659C...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
40683C...Anomalous parametrizations for different strategies
40684C...for off-shell photons; except full integration.
40685
40686C...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
40693C...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
40706C...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
40726C...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
40734C...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
40742C...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
40755C*********************************************************************
40756
40757CDECK ID>, PHO_SASVMD
40758 SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40759C...Purpose: to evaluate the VMD parton distributions of a photon,
40760C...evolved homogeneously from an initial scale P2 to Q2.
40761C...Does not include dipole suppression factor.
40762C...ISET is parton distribution set, see above;
40763C...additionally ISET=0 is used for the evolution of an anomalous photon
40764C...which branched at a scale P2 and then evolved homogeneously to Q2.
40765C...ALAM is the 4-flavour Lambda, which is automatically converted
40766C...to 3- and 5-flavour equivalents as needed.
40767 SAVE
40768 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40769
40770C 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
40776C...Reset output.
40777 DO 100 KFL=-6,6
40778 XPGA(KFL)=0.
40779 VXPGA(KFL)=0.
40780 100 CONTINUE
40781 KFA=IABS(KF)
40782
40783C...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
40791C...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
40799C...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
40819C...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
40826C...Evaluate homogeneous anomalous parton distributions below or
40827C...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
40847C...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
40866C...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
40886C...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
40905C...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
40928C...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
40949C...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
40966C*********************************************************************
40967
40968CDECK ID>, PHO_SASANO
40969 SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40970C...Purpose: to evaluate the parton distributions of the anomalous
40971C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
40972C...to Q2.
40973C...KF=0 gives the sum over (up to) 5 flavours,
40974C...KF<0 limits to flavours up to abs(KF),
40975C...KF>0 is for flavour KF only.
40976C...ALAM is the 4-flavour Lambda, which is automatically converted
40977C...to 3- and 5-flavour equivalents as needed.
40978 SAVE
40979
40980C 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
40987C...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
40995C...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
41005C...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
41013C...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
41025C...Loop over flavours the photon can branch into.
41026 DO 110 KFL=KFLMN,KFLMX
41027
41028C...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
41051C...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
41054C...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
41071C...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
41081C...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
41086C...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
41100C...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
41114C...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
41131C*********************************************************************
41132
41133CDECK ID>, PHO_SASBEH
41134 SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41135C...Purpose: to evaluate the Bethe-Heitler cross section for
41136C...heavy flavour production.
41137 SAVE
41138 DATA AEM2PI/0.0011614/
41139
41140C...Reset output.
41141 XPBH=0.
41142 SIGBH=0.
41143
41144C...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
41152C...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
41162C...Complicated case: P2 > 0, based on approximation of
41163C...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
41182C...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
41189C*********************************************************************
41190
41191CDECK ID>, PHO_SASDIR
41192 SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41193C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41194C...as needed in MSbar parametrizations.
41195 SAVE
41196 DIMENSION XPGA(-6:6)
41197 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41198
41199C...Reset output.
41200 DO 100 KFL=-6,6
41201 XPGA(KFL)=0.
41202 100 CONTINUE
41203
41204C...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
41208C...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
41213C...Also fill for antiquarks.
41214 DO 110 KF=1,5
41215 XPGA(-KF)=XPGA(KF)
41216 110 CONTINUE
41217
41218 END
41219
41220CDECK ID>, PHO_PHGAL
41221 SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41222C***********************************************************************
41223C
41224C photon parton densities with built-in momentum sum rule and
41225C Regge-based low-x behaviour
41226C
41227C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41228C e-Print Archive: hep-ph/9711355
41229C
41230C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41231C
41232C***********************************************************************
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
41245C...100 x values; in (D-4,.77) log spaced (78 points)
41246C... 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
41267C...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
41899C..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)
41913C..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
41925CDECK ID>, PHO_DBFINT
41926 DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
41927C***********************************************************************
41928C
41929C routine based on CERN library E104
41930C
41931C multi-dimensional interpolation routine, needed for PHOJET
41932C internal cross section tables and several PDF sets (GRV98 and AGL)
41933C
41934C changed to avoid recursive function calls (R.Engel, 09/98)
41935C
41936C***********************************************************************
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
42004CDECK ID>, PHVAL
42005 SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
42006C**********************************************************************
42007C
42008C dummy subroutine, remove to link PHOLIB
42009C
42010C**********************************************************************
42011 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42012 DIMENSION PD(-6:6)
42013 END