]> 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
Removing warnings (Sun)
[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
32052
32053 Nin = abs(IDpdg)
32054
32055 if((Nin.gt.99999).or.(Nin.eq.0)) then
32056C invalid particle number
32057 if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32058 & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
32059 ipho_pdg2id = 0
32060 return
32061 else If(Nin.le.577) then
32062C simple case
32063 Nout = Nin
32064 else
32065C use hash algorithm
32066 Nout = mod(Nin,577)
32067 endif
32068
32069 100 continue
32070
32071C particle not in table
32072 if(ID_list(Nout).Eq.0) then
32073 if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32074 & 'ipho_pdg2id: particle not in table ',IDpdg
32075 ipho_pdg2id = 0
32076 return
32077 endif
32078
32079 if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32080C particle ID found
32081 ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32082 return
32083 else
32084C increment and try again
32085 Nout = Nout + 5
32086 If(Nout.gt.577) Nout = Mod(Nout,577)
32087 goto 100
32088 endif
32089
32090 END
32091
32092CDECK ID>, IPHO_ID2PDG
32093 INTEGER FUNCTION ipho_id2pdg(IDcpc)
32094C**********************************************************************
32095C
32096C conversion of internal particle code to PDG standard
32097C
32098C input: IDcpc internal particle number
32099C output: ipho_id2pdg PDG particle number
32100C (0 for invalid IDcpc)
32101C
32102C**********************************************************************
32103
32104 IMPLICIT NONE
32105
32106 SAVE
32107
32108 integer IDcpc
32109
32110C input/output channels
32111 INTEGER LI,LO
32112 COMMON /POINOU/ LI,LO
32113C event debugging information
32114 INTEGER NMAXD
32115 PARAMETER (NMAXD=100)
32116 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32117 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32118 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32119 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32120C particle ID translation table
32121 integer ID_pdg_list,ID_list,ID_pdg_max
32122 character*12 name_list
32123 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32124 & ID_pdg_max
32125
32126 integer IDabs
32127
32128 IDabs = abs(IDcpc)
32129 if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32130 ipho_id2pdg = 0
32131 return
32132 endif
32133
32134 ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32135
32136 END
32137
32138CDECK ID>, IPHO_LU2PDG
32139 INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32140C**********************************************************************
32141C
32142C conversion of JETSET KF code to PDG code
32143C
32144C**********************************************************************
32145 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32146 SAVE
32147 PARAMETER (NTAB=10)
32148 DIMENSION LU2PD(2,NTAB)
32149 DATA LU2PD / 4232, 4322,
32150 & 4322, 4232,
32151 & 3212, 3122,
32152 & 3122, 3212,
32153 & 30553, 20553,
32154 & 30443, 20443,
32155 & 20443, 10443,
32156 & 10443, 0,
32157 & 511, 0,
32158 & 10551, 551 /
32159C
32160 DO 100 I=1,NTAB
32161 IF(LU2PD(1,I).EQ.LUKF) THEN
32162 IPHO_LU2PDG=LU2PD(2,I)
32163 RETURN
32164 ENDIF
32165 100 CONTINUE
32166 IPHO_LU2PDG=LUKF
32167
32168 END
32169
32170CDECK ID>, IPHO_PDG2LU
32171 INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32172C**********************************************************************
32173C
32174C conversion of PDG code to JETSET code
32175C
32176C**********************************************************************
32177 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32178 SAVE
32179 PARAMETER (NTAB=8)
32180 DIMENSION LU2PD(2,NTAB)
32181 DATA LU2PD / 4232, 4322,
32182 & 4322, 4232,
32183 & 3212, 3122,
32184 & 3122, 3212,
32185 & 30553, 20553,
32186 & 30443, 20443,
32187 & 20443, 10443,
32188 & 10551, 551 /
32189C
32190 DO 100 I=1,NTAB
32191 IF(LU2PD(2,I).EQ.IPDG) THEN
32192 IPHO_PDG2LU=LU2PD(1,I)
32193 RETURN
32194 ENDIF
32195 100 CONTINUE
32196 IPHO_PDG2LU=IPDG
32197
32198 END
32199
32200CDECK ID>, pho_pname
32201 CHARACTER*15 FUNCTION pho_pname(ID,mode)
32202C***********************************************************************
32203C
32204C returns particle name for given ID number
32205C
32206C input: ID particle ID number
32207C mode 0: ID treated as compressed particle code
32208C 1: ID treated as PDG number
32209C
32210C***********************************************************************
32211
32212 IMPLICIT NONE
32213
32214 SAVE
32215
32216 integer ID,mode
32217
32218C input/output channels
32219 INTEGER LI,LO
32220 COMMON /POINOU/ LI,LO
32221
32222C standard particle data interface
32223 INTEGER NMXHEP
32224
32225 PARAMETER (NMXHEP=4000)
32226
32227 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32228 DOUBLE PRECISION PHEP,VHEP
32229 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32230 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32231 & VHEP(4,NMXHEP)
32232C extension to standard particle data interface (PHOJET specific)
32233 INTEGER IMPART,IPHIST,ICOLOR
32234 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32235
32236C particle ID translation table
32237 integer ID_pdg_list,ID_list,ID_pdg_max
32238 character*12 name_list
32239 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32240 & ID_pdg_max
32241C general particle data
32242 double precision xm_list,tau_list,gam_list,
32243 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32244 & xm_bb82_list,xm_bb102_list
32245 integer ich3_list,iba3_list,iq_list,
32246 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32247 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32248 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32249 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32250 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32251 & ich3_list(300),iba3_list(300),iq_list(3,300),
32252 & id_psm_list(6,6),id_vem_list(6,6),
32253 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32254
32255C external functions
32256 integer ipho_id2pdg,ipho_pdg2id
32257
32258C local variables
32259 integer IDpdg,i,ii,k,l,ichar,i_anti
32260 character*15 name
32261
32262 pho_pname = '(?????????????)'
32263
32264 if(mode.eq.0) then
32265 i = ID
32266 IDpdg = ipho_id2pdg(ID)
32267 if(IDpdg.eq.0) return
32268 else if(mode.eq.1) then
32269 i = ipho_pdg2id(ID)
32270 if(i.eq.0) return
32271 IDpdg = ID
32272 else if(mode.eq.2) then
32273 if(ISTHEP(ID).gt.11) then
32274 if(ISTHEP(ID).eq.20) then
32275 pho_pname = 'hard ini. part.'
32276 else if(ISTHEP(ID).eq.21) then
32277 pho_pname = 'hard fin. part.'
32278 else if(ISTHEP(ID).eq.25) then
32279 pho_pname = 'hard scattering'
32280 else if(ISTHEP(ID).eq.30) then
32281 pho_pname = 'diff. diss. '
32282 else if(ISTHEP(ID).eq.35) then
32283 pho_pname = 'elastic scatt. '
32284 else if(ISTHEP(ID).eq.40) then
32285 pho_pname = 'central scatt. '
32286 endif
32287 return
32288 endif
32289 IDpdg = IDHEP(ID)
32290 i = IMPART(ID)
32291 else
32292 WRITE(LO,'(1x,a,2i4)')
32293 & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
32294 return
32295 endif
32296
32297 ii = abs(i)
32298 if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32299
32300 name = name_list(ii)
32301 ichar = ich3_list(ii)*sign(1,i)
32302 if(mod(ichar,3).ne.0) then
32303 ichar = 0
32304 else
32305 ichar = ichar/3
32306 endif
32307
32308C find position of first blank character
32309 k = 1
32310 100 continue
32311 k = k+1
32312 if(name(k:k).ne.' ') goto 100
32313
32314C append anti-particle sign
32315 if(i.lt.0) then
32316 i_anti = 0
32317 do l=1,3
32318 i_anti = i_anti+iq_list(l,ii)
32319 enddo
32320 if(iba3_list(ii).ne.0) then
32321 name(k:k) = '~'
32322 k = K+1
32323 else if(((i_anti.ne.0).and.(ichar.eq.0))
32324 & .or.(IDpdg.eq.-12)
32325 & .or.(IDpdg.eq.-14)
32326 & .or.(IDpdg.eq.-16)) then
32327 name(k:k) = '~'
32328 k = K+1
32329 endif
32330 endif
32331
32332C append charge sign
32333 if(ichar.eq.-2) then
32334 name(k:k+1) = '--'
32335 else if(ichar.eq.-1) then
32336 name(k:k) = '-'
32337 else if(ichar.eq.1) then
32338 name(k:k) = '+'
32339 else if(ichar.eq.2) then
32340 name(k:k+1) = '++'
32341 endif
32342
32343 pho_pname = name
32344
32345 END
32346
32347CDECK ID>, ipho_anti
32348 INTEGER FUNCTION ipho_anti(ID)
32349C**********************************************************************
32350C
32351C determine antiparticle for given ID
32352C
32353C input: ID gives CPC particle number
32354C
32355C output: ipho_anti antiparticle code
32356C
32357C**********************************************************************
32358
32359 IMPLICIT NONE
32360
32361 SAVE
32362
32363 integer ID
32364
32365C input/output channels
32366 INTEGER LI,LO
32367 COMMON /POINOU/ LI,LO
32368C event debugging information
32369 INTEGER NMAXD
32370 PARAMETER (NMAXD=100)
32371 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32372 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32373 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32374 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32375C particle ID translation table
32376 integer ID_pdg_list,ID_list,ID_pdg_max
32377 character*12 name_list
32378 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32379 & ID_pdg_max
32380C general particle data
32381 double precision xm_list,tau_list,gam_list,
32382 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32383 & xm_bb82_list,xm_bb102_list
32384 integer ich3_list,iba3_list,iq_list,
32385 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32386 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32387 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32388 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32389 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32390 & ich3_list(300),iba3_list(300),iq_list(3,300),
32391 & id_psm_list(6,6),id_vem_list(6,6),
32392 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32393
32394C standard particle data interface
32395 INTEGER NMXHEP
32396
32397 PARAMETER (NMXHEP=4000)
32398
32399 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32400 DOUBLE PRECISION PHEP,VHEP
32401 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32402 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32403 & VHEP(4,NMXHEP)
32404C extension to standard particle data interface (PHOJET specific)
32405 INTEGER IMPART,IPHIST,ICOLOR
32406 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32407
32408C external functions
32409 integer ipho_id2pdg,ipho_pdg2id
32410
32411C local variables
32412 integer IDabs,IDpdg,i_anti,l
32413
32414 ipho_anti = -ID
32415 IDabs = abs(ID)
32416
32417C baryons
32418 if(iba3_list(IDabs).ne.0) return
32419
32420C charged particles
32421 if(ich3_list(IDabs).ne.0) return
32422
32423C K0_s and K0_l
32424 IDpdg = ipho_id2pdg(ID)
32425 if(IDpdg.eq.310) then
32426 ID = ipho_pdg2id(130)
32427 return
32428 else if(IDpdg.eq.130) then
32429 ID = ipho_pdg2id(310)
32430 return
32431 endif
32432
32433C neutral mesons with open strangeness, charm, or beauty
32434 i_anti = 0
32435 do l=1,3
32436 i_anti = i_anti+iq_list(l,IDabs)
32437 enddo
32438 if(i_anti.ne.0) return
32439
32440C neutrinos
32441 IDpdg = abs(IDpdg)
32442 if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32443
32444 ipho_anti = ID
32445
32446 END
32447
32448CDECK ID>, ipho_chr3
32449 INTEGER FUNCTION ipho_chr3(ID,mode)
32450C**********************************************************************
32451C
32452C output of three times the electric charge
32453C
32454C input: mode
32455C 0 ID gives CPC particle number
32456C 1 ID gives PDG particle number
32457C 2 ID gives position of particle in /POEVT1/
32458C
32459C**********************************************************************
32460
32461 IMPLICIT NONE
32462
32463 SAVE
32464
32465 integer ID,mode
32466
32467C input/output channels
32468 INTEGER LI,LO
32469 COMMON /POINOU/ LI,LO
32470C event debugging information
32471 INTEGER NMAXD
32472 PARAMETER (NMAXD=100)
32473 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32474 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32475 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32476 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32477
32478C standard particle data interface
32479 INTEGER NMXHEP
32480
32481 PARAMETER (NMXHEP=4000)
32482
32483 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32484 DOUBLE PRECISION PHEP,VHEP
32485 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32486 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32487 & VHEP(4,NMXHEP)
32488C extension to standard particle data interface (PHOJET specific)
32489 INTEGER IMPART,IPHIST,ICOLOR
32490 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32491
32492C particle ID translation table
32493 integer ID_pdg_list,ID_list,ID_pdg_max
32494 character*12 name_list
32495 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32496 & ID_pdg_max
32497C general particle data
32498 double precision xm_list,tau_list,gam_list,
32499 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32500 & xm_bb82_list,xm_bb102_list
32501 integer ich3_list,iba3_list,iq_list,
32502 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32503 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32504 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32505 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32506 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32507 & ich3_list(300),iba3_list(300),iq_list(3,300),
32508 & id_psm_list(6,6),id_vem_list(6,6),
32509 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32510
32511C external functions
32512 integer ipho_pdg2id
32513
32514C local variables
32515 integer i,IDpdg
32516
32517 ipho_chr3 = 0
32518
32519 if(mode.eq.0) then
32520 i = ID
32521 else if(mode.eq.1) then
32522 i = ipho_pdg2id(ID)
32523 if(i.eq.0) return
32524 IDpdg = ID
32525 else if(mode.eq.2) then
32526 if(ISTHEP(ID).gt.11) return
32527 i = IMPART(ID)
32528 IDpdg = IDHEP(ID)
32529 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32530 ipho_chr3 = ICOLOR(1,ID)
32531 return
32532 endif
32533 else
32534 WRITE(LO,'(1x,a,2i4)')
32535 & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32536 return
32537 endif
32538
32539 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32540 WRITE(LO,'(1x,a,3i8)')
32541 & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32542 ipho_chr3 = 1.D0/dble(i)
32543 call pho_prevnt(0)
32544 return
32545 endif
32546
32547 ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32548
32549 END
32550
32551CDECK ID>, ipho_bar3
32552 INTEGER FUNCTION ipho_bar3(ID,mode)
32553C**********************************************************************
32554C
32555C output of three times the baryon charge
32556C
32557C index: MODE
32558C 0 ID gives CPC particle number
32559C 1 ID gives PDG particle number
32560C 2 ID gives position of particle in /POEVT1/
32561C
32562C**********************************************************************
32563
32564 IMPLICIT NONE
32565
32566 SAVE
32567
32568 integer ID,mode
32569
32570C input/output channels
32571 INTEGER LI,LO
32572 COMMON /POINOU/ LI,LO
32573C event debugging information
32574 INTEGER NMAXD
32575 PARAMETER (NMAXD=100)
32576 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32577 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32578 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32579 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32580
32581C standard particle data interface
32582 INTEGER NMXHEP
32583
32584 PARAMETER (NMXHEP=4000)
32585
32586 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32587 DOUBLE PRECISION PHEP,VHEP
32588 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32589 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32590 & VHEP(4,NMXHEP)
32591C extension to standard particle data interface (PHOJET specific)
32592 INTEGER IMPART,IPHIST,ICOLOR
32593 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32594
32595C particle ID translation table
32596 integer ID_pdg_list,ID_list,ID_pdg_max
32597 character*12 name_list
32598 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32599 & ID_pdg_max
32600C general particle data
32601 double precision xm_list,tau_list,gam_list,
32602 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32603 & xm_bb82_list,xm_bb102_list
32604 integer ich3_list,iba3_list,iq_list,
32605 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32606 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32607 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32608 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32609 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32610 & ich3_list(300),iba3_list(300),iq_list(3,300),
32611 & id_psm_list(6,6),id_vem_list(6,6),
32612 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32613
32614C external functions
32615 integer ipho_pdg2id
32616
32617C local variables
32618 integer i,IDpdg
32619
32620 ipho_bar3 = 0
32621
32622 if(mode.eq.0) then
32623 i = ID
32624 else if(mode.eq.1) then
32625 i = ipho_pdg2id(ID)
32626 if(i.eq.0) return
32627 IDpdg = ID
32628 else if(mode.eq.2) then
32629 if(ISTHEP(ID).gt.11) return
32630 i = IMPART(ID)
32631 IDpdg = IDHEP(ID)
32632 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32633 ipho_bar3 = ICOLOR(2,ID)
32634 return
32635 endif
32636 else
32637 WRITE(LO,'(1x,a,2i4)')
32638 & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32639 return
32640 endif
32641
32642 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32643 WRITE(LO,'(1x,a,3i8)')
32644 & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32645 ipho_bar3 = 1.D0/dble(i)
32646 return
32647 endif
32648
32649 ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32650
32651 END
32652
32653CDECK ID>, pho_pmass
32654 DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32655C***********************************************************************
32656C
32657C particle mass
32658C
32659C input: mode -1 initialization
32660C 0 ID gives CPC particle number
32661C 1 ID gives PDG particle number,
32662C (for quarks current masses are returned)
32663C 2 ID gives position of particle in /POEVT1/
32664C 3 ID gives PDG parton number,
32665C (for quarks constituent masses are returned)
32666C
32667C output: average particle mass (in GeV)
32668C
32669C***********************************************************************
32670
32671 IMPLICIT NONE
32672
32673 SAVE
32674
32675 integer ID,mode,MSTJ24
32676
32677C input/output channels
32678 INTEGER LI,LO
32679 COMMON /POINOU/ LI,LO
32680C event debugging information
32681 INTEGER NMAXD
32682 PARAMETER (NMAXD=100)
32683 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32684 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32685 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32686 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32687C model switches and parameters
32688 CHARACTER*8 MDLNA
32689 INTEGER ISWMDL,IPAMDL
32690 DOUBLE PRECISION PARMDL
32691 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32692
32693C standard particle data interface
32694 INTEGER NMXHEP
32695
32696 PARAMETER (NMXHEP=4000)
32697
32698 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32699 DOUBLE PRECISION PHEP,VHEP
32700 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32701 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32702 & VHEP(4,NMXHEP)
32703C extension to standard particle data interface (PHOJET specific)
32704 INTEGER IMPART,IPHIST,ICOLOR
32705 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32706
32707C particle ID translation table
32708 integer ID_pdg_list,ID_list,ID_pdg_max
32709 character*12 name_list
32710 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32711 & ID_pdg_max
32712C general particle data
32713 double precision xm_list,tau_list,gam_list,
32714 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32715 & xm_bb82_list,xm_bb102_list
32716 integer ich3_list,iba3_list,iq_list,
32717 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32718 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32719 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32720 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32721 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32722 & ich3_list(300),iba3_list(300),iq_list(3,300),
32723 & id_psm_list(6,6),id_vem_list(6,6),
32724 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32725
32726 INTEGER MSTU,MSTJ
32727 DOUBLE PRECISION PARU,PARJ
32728 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32729
32730C external functions
32731 integer ipho_pdg2id,ipho_id2pdg
32732
32733 DOUBLE PRECISION PYMASS
32734
32735C local variables
32736 integer i,IDpdg
32737
32738 pho_pmass = 0.D0
32739
32740 if(mode.eq.0) then
32741 i = ID
32742 else if(mode.eq.1) then
32743 i = ipho_pdg2id(ID)
32744 if(i.eq.0) return
32745 else if(mode.eq.2) then
32746 if(ISTHEP(ID).gt.11) return
32747 i = IMPART(ID)
32748 IDpdg = IDHEP(ID)
32749 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32750 pho_pmass = PHEP(5,ID)
32751 return
32752 endif
32753 else if(mode.eq.3) then
32754 i = abs(ID)
32755 if((i.gt.0).and.(i.le.6)) then
32756 pho_pmass = PARMDL(150+i)
32757 return
32758 else
32759 i = ipho_pdg2id(ID)
32760 if(i.eq.0) return
32761 endif
32762 else if(mode.eq.-1) then
32763C initialization: take masses for quarks and di-quarks from JETSET
32764 MSTJ24 = MSTJ(24)
32765 MSTJ(24) = 0
32766 do i=1,22
32767 IDpdg = ipho_id2pdg(i)
32768
32769 xm_list(i) = PYMASS(IDpdg)
32770
32771 enddo
32772 MSTJ(24) = MSTJ24
32773 return
32774 else
32775 WRITE(LO,'(1x,a,2i4)')
32776 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32777 return
32778 endif
32779
32780 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32781 WRITE(LO,'(1x,a,2i8)')
32782 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32783 pho_pmass = 1.D0/dble(i)
32784 return
32785 endif
32786
32787 pho_pmass = xm_list(iabs(i))
32788
32789 END
32790
32791CDECK ID>, PHO_MEMASS
32792 SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
32793C**********************************************************************
32794C
32795C determine meson masses corresponding to the input flavours
32796C
32797C input: I,J,K quark flavours (PDG convention)
32798C
32799C output: AMPS pseudo scalar meson mass
32800C AMPS2 next possible two particle configuration
32801C (two pseudo scalar mesons)
32802C AMVE vector meson mass
32803C AMVE2 next possible two particle configuration
32804C (two vector mesons)
32805C IPS,IVE meson numbers in CPC
32806C
32807C**********************************************************************
32808
32809 IMPLICIT NONE
32810
32811 SAVE
32812
32813 integer I,J,IPS,IVE
32814 double precision AMPS,AMPS2,AMVE,AMVE2
32815
32816C input/output channels
32817 INTEGER LI,LO
32818 COMMON /POINOU/ LI,LO
32819C event debugging information
32820 INTEGER NMAXD
32821 PARAMETER (NMAXD=100)
32822 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32823 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32824 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32825 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32826C particle ID translation table
32827 integer ID_pdg_list,ID_list,ID_pdg_max
32828 character*12 name_list
32829 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32830 & ID_pdg_max
32831C general particle data
32832 double precision xm_list,tau_list,gam_list,
32833 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32834 & xm_bb82_list,xm_bb102_list
32835 integer ich3_list,iba3_list,iq_list,
32836 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32837 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32838 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32839 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32840 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32841 & ich3_list(300),iba3_list(300),iq_list(3,300),
32842 & id_psm_list(6,6),id_vem_list(6,6),
32843 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32844
32845C local variables
32846 integer ii,jj
32847
32848 IF(I.GT.0) THEN
32849 ii = I
32850 jj = -J
32851 ELSE
32852 ii = J
32853 jj = -I
32854 ENDIF
32855
32856C particle ID's
32857 IPS = id_psm_list(ii,jj)
32858 IVE = id_vem_list(ii,jj)
32859C masses
32860 if(IPS.ne.0) then
32861 AMPS = xm_list(iabs(IPS))
32862 else
32863 AMPS = 0.D0
32864 endif
32865 if(IVE.ne.0) then
32866 AMVE = xm_list(iabs(IVE))
32867 else
32868 AMVE = 0.D0
32869 endif
32870
32871C next possible two-particle configurations (add phase space)
32872 AMPS2 = xm_psm2_list(ii,jj)*1.5D0
32873 AMVE2 = xm_vem2_list(ii,jj)*1.1D0
32874
32875 END
32876
32877CDECK ID>, PHO_BAMASS
32878 SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
32879C**********************************************************************
32880C
32881C determine baryon masses corresponding to the input flavours
32882C
32883C input: I,J,K quark flavours (PDG convention)
32884C
32885C output: AM8 octett baryon mass
32886C AM82 next possible two particle configuration
32887C (octett baryon and meson)
32888C AM10 decuplett baryon mass
32889C AM102 next possible two particle configuration
32890C (decuplett baryon and meson,
32891C baryon built up from first two quarks)
32892C I8,I10 internal baryon numbers
32893C
32894C**********************************************************************
32895
32896 IMPLICIT NONE
32897
32898 SAVE
32899
32900 integer I,J,K,I8,I10
32901 double precision AM8,AM82,AM10,AM102
32902
32903C input/output channels
32904 INTEGER LI,LO
32905 COMMON /POINOU/ LI,LO
32906C event debugging information
32907 INTEGER NMAXD
32908 PARAMETER (NMAXD=100)
32909 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32910 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32911 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32912 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32913C particle ID translation table
32914 integer ID_pdg_list,ID_list,ID_pdg_max
32915 character*12 name_list
32916 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32917 & ID_pdg_max
32918C general particle data
32919 double precision xm_list,tau_list,gam_list,
32920 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32921 & xm_bb82_list,xm_bb102_list
32922 integer ich3_list,iba3_list,iq_list,
32923 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32924 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32925 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32926 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32927 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32928 & ich3_list(300),iba3_list(300),iq_list(3,300),
32929 & id_psm_list(6,6),id_vem_list(6,6),
32930 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32931
32932C local variables
32933 integer ii,jj,kk
32934
32935C find particle ID's
32936 ii = iabs(I)
32937 jj = iabs(J)
32938 kk = iabs(K)
32939 I8 = id_b8_list(ii,jj,kk)
32940 I10 = id_b10_list(ii,jj,kk)
32941
32942C masses (if combination possible)
32943 if(I8.ne.0) then
32944 AM8 = xm_list(I8)
32945 I8 = sign(I8,i)
32946 else
32947 AM8 = 0.D0
32948 endif
32949 if(I10.ne.0) then
32950 AM10 = xm_list(I10)
32951 I10 = sign(I10,i)
32952 else
32953 AM10 = 0.D0
32954 endif
32955
32956C next possible two-particle configurations (add phase space)
32957 AM82 = xm_b82_list(ii,jj,kk)*1.5D0
32958 AM102 = xm_b102_list(ii,jj,kk)*1.1D0
32959
32960 END
32961
32962CDECK ID>, PHO_DQMASS
32963 SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
32964C**********************************************************************
32965C
32966C determine minimal masses corresponding to the input flavours
32967C (diquark a-diquark string system)
32968C
32969C input: I,J,K,L quark flavours (PDG convention)
32970C
32971C output: AM82 mass of two octett baryons
32972C AM102 mass of two decuplett baryons
32973C
32974C**********************************************************************
32975
32976 IMPLICIT NONE
32977
32978 SAVE
32979
32980 integer I,J,K,L
32981 double precision AM82,AM102
32982
32983C input/output channels
32984 INTEGER LI,LO
32985 COMMON /POINOU/ LI,LO
32986C event debugging information
32987 INTEGER NMAXD
32988 PARAMETER (NMAXD=100)
32989 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32990 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32991 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32992 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32993C general particle data
32994 double precision xm_list,tau_list,gam_list,
32995 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32996 & xm_bb82_list,xm_bb102_list
32997 integer ich3_list,iba3_list,iq_list,
32998 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32999 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33000 & xm_psm2_list(6,6),xm_vem2_list(6,6),
33001 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33002 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33003 & ich3_list(300),iba3_list(300),iq_list(3,300),
33004 & id_psm_list(6,6),id_vem_list(6,6),
33005 & id_b8_list(6,6,6),id_b10_list(6,6,6)
33006
33007C local variables
33008 integer ii,jj,kk,ll
33009
33010 ii = iabs(i)
33011 kk = iabs(k)
33012 jj = iabs(j)
33013 ll = iabs(l)
33014
33015 AM82 = xm_bb82_list(ii,jj,kk,ll)
33016 AM102 = xm_bb102_list(ii,jj,kk,ll)
33017
33018 END
33019
33020CDECK ID>, PHO_CHECK
33021 SUBROUTINE PHO_CHECK(MD,IDEV)
33022C**********************************************************************
33023C
33024C check quantum numbers of entries in /POEVT1/ and /POEVT2/
33025C (energy, momentum, charge, baryon number conservation)
33026C
33027C input: MD -1 check overall momentum conservation
33028C and perform detailed check only in case of
33029C deviations
33030C 1 test all branchings, mother-daughter
33031C relations
33032C
33033C output: IDEV 0 no deviations
33034C 1 deviations found
33035C
33036C**********************************************************************
33037 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33038 SAVE
33039
33040C input/output channels
33041 INTEGER LI,LO
33042 COMMON /POINOU/ LI,LO
33043C event debugging information
33044 INTEGER NMAXD
33045 PARAMETER (NMAXD=100)
33046 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33047 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33048 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33049 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33050C model switches and parameters
33051 CHARACTER*8 MDLNA
33052 INTEGER ISWMDL,IPAMDL
33053 DOUBLE PRECISION PARMDL
33054 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33055C global event kinematics and particle IDs
33056 INTEGER IFPAP,IFPAB
33057 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33058 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33059C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33060 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33061 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33062 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33063 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33064
33065C standard particle data interface
33066 INTEGER NMXHEP
33067
33068 PARAMETER (NMXHEP=4000)
33069
33070 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33071 DOUBLE PRECISION PHEP,VHEP
33072 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33073 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33074 & VHEP(4,NMXHEP)
33075C extension to standard particle data interface (PHOJET specific)
33076 INTEGER IMPART,IPHIST,ICOLOR
33077 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33078
33079C color string configurations including collapsed strings and hadrons
33080 INTEGER MSTR
33081 PARAMETER (MSTR=500)
33082 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33083 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33084 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33085 & NNCH(MSTR),IBHAD(MSTR),ISTR
33086
33087C count number of errors to avoid disk overflow
33088 DATA IERR / 0 /
33089
33090 IDEV = 0
33091C conservation check suppressed
33092 IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33093
33094 IF(IPAMDL(13).GT.0) THEN
33095
33096C DPMJET call with x limitations
33097 MODE = -1
33098 ECM1 = SQRT(XPSUB*XTSUB)*ECM
33099
33100 ELSE
33101
33102C standard call
33103 MODE = MD
33104C first two entries are considered as scattering particles
33105 EE1 = PHEP(4,1) + PHEP(4,2)
33106 PX1 = PHEP(1,1) + PHEP(1,2)
33107 PY1 = PHEP(2,1) + PHEP(2,2)
33108 PZ1 = PHEP(3,1) + PHEP(3,2)
33109
33110 ENDIF
33111
33112 DDREL = PARMDL(75)
33113 DDABS = PARMDL(76)
33114 IF(MODE.EQ.-1) GOTO 500
33115
33116 50 CONTINUE
33117
33118 I = 1
33119 100 CONTINUE
33120
33121C recognize only decayed particles as mothers
33122 IF(ISTHEP(I).EQ.2) THEN
33123C search for other mother particles
33124 K = JDAHEP(1,I)
33125 IF(K.EQ.0) THEN
33126 IF(IPAMDL(178).NE.0)
33127 & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33128 & 'entry marked as decayed but no dauther given:',I
33129 GOTO 99
33130 ENDIF
33131 K1 = JMOHEP(1,K)
33132 K2 = JMOHEP(2,K)
33133C sum over mother particles
33134 ICH1 = IPHO_CHR3(K1,2)
33135 IBA1 = IPHO_BAR3(K1,2)
33136 EE1 = PHEP(4,K1)
33137 PX1 = PHEP(1,K1)
33138 PY1 = PHEP(2,K1)
33139 PZ1 = PHEP(3,K1)
33140 IF(K2.LT.0) THEN
33141 K2 = -K2
33142 IF((K1.GT.I).OR.(K2.LT.I)) THEN
33143 WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33144 & 'inconsistent mother/daughter relation found',I,K1,K2
33145 CALL PHO_PREVNT(-1)
33146 ENDIF
33147 DO 400 II=K1+1,K2
33148 IF(ABS(ISTHEP(II)).LE.2) THEN
33149 ICH1 = ICH1 + IPHO_CHR3(II,2)
33150 IBA1 = IBA1 + IPHO_BAR3(II,2)
33151 EE1 = EE1 + PHEP(4,II)
33152 PX1 = PX1 + PHEP(1,II)
33153 PY1 = PY1 + PHEP(2,II)
33154 PZ1 = PZ1 + PHEP(3,II)
33155 ENDIF
33156 400 CONTINUE
33157 ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33158 ICH1 = ICH1 + IPHO_CHR3(K2,2)
33159 IBA1 = IBA1 + IPHO_BAR3(K2,2)
33160 EE1 = EE1 + PHEP(4,K2)
33161 PX1 = PX1 + PHEP(1,K2)
33162 PY1 = PY1 + PHEP(2,K2)
33163 PZ1 = PZ1 + PHEP(3,K2)
33164 ENDIF
33165
33166C sum over daughter particles
33167 ICH2 = 0.D0
33168 IBA2 = 0.D0
33169 EE2 = 0.D0
33170 PX2 = 0.D0
33171 PY2 = 0.D0
33172 PZ2 = 0.D0
33173 DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33174 IF(ABS(ISTHEP(II)).LE.2) THEN
33175 ICH2 = ICH2 + IPHO_CHR3(II,2)
33176 IBA2 = IBA2 + IPHO_BAR3(II,2)
33177 EE2 = EE2 + PHEP(4,II)
33178 PX2 = PX2 + PHEP(1,II)
33179 PY2 = PY2 + PHEP(2,II)
33180 PZ2 = PZ2 + PHEP(3,II)
33181 ENDIF
33182 200 CONTINUE
33183
33184C conservation check
33185 ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33186 IF(ABS(EE1-EE2).GT.ESC) THEN
33187 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33188 & 'PHO_CHECK: energy conservation violated for',
33189 & 'entry,initial,final:',I,EE1,EE2
33190 IDEV = 1
33191 ENDIF
33192 ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33193 IF(ABS(PX1-PX2).GT.ESC) THEN
33194 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33195 & 'PHO_CHECK: x-momentum conservation violated for',
33196 & 'entry,initial,final:',I,PX1,PX2
33197 IDEV = 1
33198 ENDIF
33199 ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33200 IF(ABS(PY1-PY2).GT.ESC) THEN
33201 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33202 & 'PHO_CHECK: y-momentum conservation violated for',
33203 & 'entry,initial,final:',I,PY1,PY2
33204 IDEV = 1
33205 ENDIF
33206 ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33207 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33208 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33209 & 'PHO_CHECK: z-momentum conservation violated for',
33210 & 'entry,initial,final:',I,PZ1,PZ2
33211 IDEV = 1
33212 ENDIF
33213 IF(ICH1.NE.ICH2) THEN
33214 WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33215 & 'PHO_CHECK: charge conservation violated for',
33216 & 'entry,initial,final:',I,ICH1,ICH2
33217 IDEV = 1
33218 ENDIF
33219 IF(IBA1.NE.IBA2) THEN
33220 WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33221 & 'baryon charge conservation violated for',
33222 & 'entry,initial,final:',I,IBA1,IBA2
33223 IDEV = 1
33224 ENDIF
33225 IF(IDEB(20).GE.35) THEN
33226 WRITE(LO,
33227 & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33228 & 'PHO_CHECK diagnostics:',
33229 & '(1.mother/l.mother,1.daughter/l.daughter):',
33230 & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33231 & 'mother momenta ',PX1,PY1,PZ1,EE1,
33232 & 'daughter momenta ',PX2,PY2,PZ2,EE2,
33233 & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33234 ENDIF
33235 ENDIF
33236 99 CONTINUE
33237 I = I+1
33238 IF(I.LE.NHEP) GOTO 100
33239
33240 55 CONTINUE
33241
33242 IERR = IERR+IDEV
33243
33244C write complete event in case of deviations
33245 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33246 CALL PHO_PREVNT(1)
33247 IF(ISTR.GT.0) THEN
33248 CALL PHO_PRSTRG
33249
33250 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33251
33252 ENDIF
33253 ENDIF
33254
33255C stop after too many errors
33256 IF(IERR.GT.IPAMDL(179)) THEN
33257 WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33258 & 'too many inconsistencies found, program terminated',IERR
33259 CALL PHO_ABORT
33260 ENDIF
33261
33262 RETURN
33263
33264C overall check only (less time consuming)
33265
33266 500 CONTINUE
33267
33268 ICH2 = 0.D0
33269 IBA2 = 0.D0
33270 EE2 = 0.D0
33271 PX2 = 0.D0
33272 PY2 = 0.D0
33273 PZ2 = 0.D0
33274
33275 DO 300 K=3,NHEP
33276C recognize only existing particles as possible daughters
33277 IF(ABS(ISTHEP(K)).EQ.1) THEN
33278 ICH2 = ICH2 + IPHO_CHR3(K,2)
33279 IBA2 = IBA2 + IPHO_BAR3(K,2)
33280 EE2 = EE2 + PHEP(4,K)
33281 PX2 = PX2 + PHEP(1,K)
33282 PY2 = PY2 + PHEP(2,K)
33283 PZ2 = PZ2 + PHEP(3,K)
33284 ENDIF
33285 300 CONTINUE
33286
33287C check energy-momentum conservation
33288 ESC = ECM*DDREL
33289
33290 IF(IPAMDL(13).GT.0) THEN
33291
33292C DPMJET call with x limitations
33293 ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33294 IF(ABS(ECM1-ECM2).GT.ESC) THEN
33295 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33296 & 'PHO_CHECK: c.m. energy conservation violated',
33297 & 'initial/final energy:',ECM1,ECM2
33298 IDEV = 1
33299 ENDIF
33300
33301 ELSE
33302
33303C standard call
33304 IF(ABS(EE1-EE2).GT.ESC) THEN
33305 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33306 & 'PHO_CHECK: energy conservation violated',
33307 & 'initial/final energy:',EE1,EE2
33308 IDEV = 1
33309 ENDIF
33310 IF(ABS(PX1-PX2).GT.ESC) THEN
33311 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33312 & 'PHO_CHECK: x-momentum conservation violated',
33313 & 'initial/final x-momentum:',PX1,PX2
33314 IDEV = 1
33315 ENDIF
33316 IF(ABS(PY1-PY2).GT.ESC) THEN
33317 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33318 & 'PHO_CHECK: y-momentum conservation violated',
33319 & 'initial/final y-momentum:',PY1,PY2
33320 IDEV = 1
33321 ENDIF
33322 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33323 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33324 & 'PHO_CHECK: z-momentum conservation violated',
33325 & 'initial/final z-momentum:',PZ1,PZ2
33326 IDEV = 1
33327 ENDIF
33328
33329C check of quantum number conservation
33330
33331 ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33332 IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33333
33334 IF(ICH1.NE.ICH2) THEN
33335 WRITE(LO,'(1X,A,/,5X,A,2I5)')
33336 & 'PHO_CHECK: charge conservation violated',
33337 & 'initial/final charge sum',ICH1,ICH2
33338 IDEV = 1
33339 ENDIF
33340 IF(IBA1.NE.IBA2) THEN
33341 WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33342 & 'baryonic charge conservation violated',
33343 & 'initial/final baryonic charge sum',IBA1,IBA2
33344 IDEV = 1
33345 ENDIF
33346
33347 ENDIF
33348
33349C perform detailed checks in case of deviations
33350 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33351 IF(IPAMDL(13).GT.0) THEN
33352 GOTO 55
33353 ELSE
33354 DDREL = DDREL/2.D0
33355 DDABS = DDABS/2.D0
33356 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33357 & 'increasing precision of tests to',DDREL,DDABS
33358 GOTO 50
33359 ENDIF
33360 ENDIF
33361
33362 END
33363
33364CDECK ID>, PHO_ABORT
33365 SUBROUTINE PHO_ABORT
33366C**********************************************************************
33367C
33368C top MC event generation due to fatal error,
33369C print all information of event generation and history
33370C
33371C**********************************************************************
33372 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33373 SAVE
33374
33375C input/output channels
33376 INTEGER LI,LO
33377 COMMON /POINOU/ LI,LO
33378C event debugging information
33379 INTEGER NMAXD
33380 PARAMETER (NMAXD=100)
33381 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33382 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33383 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33384 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33385C model switches and parameters
33386 CHARACTER*8 MDLNA
33387 INTEGER ISWMDL,IPAMDL
33388 DOUBLE PRECISION PARMDL
33389 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33390
33391C standard particle data interface
33392 INTEGER NMXHEP
33393
33394 PARAMETER (NMXHEP=4000)
33395
33396 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33397 DOUBLE PRECISION PHEP,VHEP
33398 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33399 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33400 & VHEP(4,NMXHEP)
33401C extension to standard particle data interface (PHOJET specific)
33402 INTEGER IMPART,IPHIST,ICOLOR
33403 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33404
33405C color string configurations including collapsed strings and hadrons
33406 INTEGER MSTR
33407 PARAMETER (MSTR=500)
33408 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33409 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33410 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33411 & NNCH(MSTR),IBHAD(MSTR),ISTR
33412C light-cone x fractions and c.m. momenta of soft cut string ends
33413 INTEGER MAXSOF
33414 PARAMETER ( MAXSOF = 50 )
33415 INTEGER IJSI2,IJSI1
33416 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33417 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33418 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33419 & IJSI1(MAXSOF),IJSI2(MAXSOF)
33420C hard scattering data
33421 INTEGER MSCAHD
33422 PARAMETER ( MSCAHD = 50 )
33423 INTEGER LSCAHD,LSC1HD,LSIDX,
33424 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33425 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33426 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33427 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33428 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33429 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33430 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33431 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33432 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33433
33434 WRITE(LO,'(//,1X,A,/,1X,A)')
33435 & 'PHO_ABORT: program execution stopped',
33436 & '===================================='
33437 WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33438C
33439 CALL PHO_SETMDL(0,0,-2)
33440 CALL PHO_PREVNT(-1)
33441 CALL PHO_ACTPDF(0,-2)
33442C print selected parton flavours
33443 WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33444 DO 700 I=1,KSOFT
33445 WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33446 700 CONTINUE
33447 WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33448 DO 750 K=1,KHARD
33449 I = LSIDX(K)
33450 WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33451 WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33452 & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33453 750 CONTINUE
33454C print selected parton momenta
33455 WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33456 DO 300 I=1,KSOFT
33457 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33458 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33459 300 CONTINUE
33460 WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33461 DO 350 K=1,KHARD
33462 I = LSIDX(K)
33463 I3 = 8*I-4
33464 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33465 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33466 350 CONTINUE
33467
33468C print /POEVT1/
33469 CALL PHO_PREVNT(0)
33470
33471C fragmentation process
33472 IF(ISTR.GT.0) THEN
33473C print /POSTRG/
33474 CALL PHO_PRSTRG
33475
33476 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33477
33478 ENDIF
33479
33480C last message
33481 WRITE(LO,'(////5X,A,///5X,A,///)')
33482 & 'PHO_ABORT: execution terminated due to fatal error',
33483 &'*** Simulating division by zero to get traceback information ***'
33484 ISTR = 100/IPAMDL(100)
33485
33486 END
33487
33488CDECK ID>, PHO_TRACE
33489 SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33490C**********************************************************************
33491C
33492C trace program subroutines according to level,
33493C original output levels will be saved
33494C
33495C input: ISTART first event to trace
33496C ISWI number of events to trace
33497C 0 loop call, use old values
33498C -1 restore original output levels
33499C 1 store level and wait for event
33500C LEVEL desired output level
33501C 0 standard output
33502C 3 internal rejections
33503C 5 cross sections, slopes etc.
33504C 10 parameter of subroutines and
33505C results
33506C 20 huge amount of debug output
33507C 30 maximal possible output
33508C
33509C**********************************************************************
33510 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33511 SAVE
33512
33513C input/output channels
33514 INTEGER LI,LO
33515 COMMON /POINOU/ LI,LO
33516C event debugging information
33517 INTEGER NMAXD
33518 PARAMETER (NMAXD=100)
33519 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33520 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33521 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33522 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33523
33524 DIMENSION IMEM(NMAXD)
33525
33526C protect ISWI
33527 ISW = ISWI
33528 10 CONTINUE
33529 IF(ISW.EQ.0) THEN
33530 IF(KEVENT.LT.ION) THEN
33531 RETURN
33532 ELSE IF(KEVENT.EQ.ION) THEN
33533 WRITE(LO,'(///,1X,A,///)')
33534 & 'PHO_TRACE: trace mode switched on'
33535 DO 100 I=1,NMAXD
33536 IMEM(I) = IDEB(I)
33537 IDEB(I) = MAX(ILEVEL,IMEM(I))
33538 100 CONTINUE
33539 ELSE IF(KEVENT.EQ.IOFF) THEN
33540 WRITE(LO,'(//,1X,A,///)')
33541 & 'PHO_TRACE: trace mode switched off'
33542 DO 200 I=1,NMAXD
33543 IDEB(I) = IMEM(I)
33544 200 CONTINUE
33545 ENDIF
33546 ELSE IF(ISW.EQ.-1) THEN
33547 DO 300 I=1,NMAXD
33548 IDEB(I) = IMEM(I)
33549 300 CONTINUE
33550 ELSE
33551C save information
33552 ION = ISTART
33553 IOFF = ISTART+ISW
33554 ILEVEL = LEVEL
33555 ENDIF
33556C check coincidence
33557 IF(ISW.GT.0) THEN
33558 ISW=0
33559 ILEVEL = LEVEL
33560 GOTO 10
33561 ENDIF
33562
33563 END
33564
33565CDECK ID>, PHO_PRSTRG
33566 SUBROUTINE PHO_PRSTRG
33567C**********************************************************************
33568C
33569C print information of /POSTRG/
33570C
33571C**********************************************************************
33572 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33573 SAVE
33574
33575C input/output channels
33576 INTEGER LI,LO
33577 COMMON /POINOU/ LI,LO
33578C event debugging information
33579 INTEGER NMAXD
33580 PARAMETER (NMAXD=100)
33581 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33582 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33583 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33584 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33585
33586C standard particle data interface
33587 INTEGER NMXHEP
33588
33589 PARAMETER (NMXHEP=4000)
33590
33591 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33592 DOUBLE PRECISION PHEP,VHEP
33593 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33594 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33595 & VHEP(4,NMXHEP)
33596C extension to standard particle data interface (PHOJET specific)
33597 INTEGER IMPART,IPHIST,ICOLOR
33598 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33599
33600C color string configurations including collapsed strings and hadrons
33601 INTEGER MSTR
33602 PARAMETER (MSTR=500)
33603 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33604 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33605 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33606 & NNCH(MSTR),IBHAD(MSTR),ISTR
33607
33608 WRITE(LO,'(/,1X,A,I5)')
33609 & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
33610 WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33611 & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
33612 WRITE(LO,'(1X,A)')
33613 & ' ======================================================='
33614 DO 800 I=1,ISTR
33615 WRITE(LO,'(1X,9I5,1P,E11.3)')
33616 & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33617 & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33618 800 CONTINUE
33619
33620 END
33621
33622CDECK ID>, PHO_PREVNT
33623 SUBROUTINE PHO_PREVNT(NPART)
33624C**********************************************************************
33625C
33626C print all information of event generation and history
33627C
33628C input: NPART -1 minimal output: process IDs
33629C 0 additional output of /POEVT1/
33630C 1 additional output of /POSTRG/
33631C 2 additional output of /HEPEVT/
33632C (call LULIST(1))
33633C
33634C**********************************************************************
33635 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33636 SAVE
33637
33638C input/output channels
33639 INTEGER LI,LO
33640 COMMON /POINOU/ LI,LO
33641C event debugging information
33642 INTEGER NMAXD
33643 PARAMETER (NMAXD=100)
33644 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33645 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33646 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33647 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33648C model switches and parameters
33649 CHARACTER*8 MDLNA
33650 INTEGER ISWMDL,IPAMDL
33651 DOUBLE PRECISION PARMDL
33652 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33653C global event kinematics and particle IDs
33654 INTEGER IFPAP,IFPAB
33655 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33656 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33657C general process information
33658 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33659 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33660
33661C standard particle data interface
33662 INTEGER NMXHEP
33663
33664 PARAMETER (NMXHEP=4000)
33665
33666 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33667 DOUBLE PRECISION PHEP,VHEP
33668 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33669 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33670 & VHEP(4,NMXHEP)
33671C extension to standard particle data interface (PHOJET specific)
33672 INTEGER IMPART,IPHIST,ICOLOR
33673 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33674
33675C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33676 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33677 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33678 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33679 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33680
33681 CHARACTER*15 PHO_PNAME
33682
33683 IF(NPART.GE.0) WRITE(LO,'(/)')
33684 WRITE(LO,'(1X,A,1PE10.3)')
33685 & 'PHO_PREVNT: c.m. energy',ECM
33686 CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33687 WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33688 & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33689 & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33690 & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33691 & KHDPO
33692 WRITE(LO,'(6X,A,I4,4I3)')
33693 & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33694 & IDIFR2,IDDPOM
33695
33696 IF(IPAMDL(13).GT.0) THEN
33697 WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33698 WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33699 & ECMN,PCMN,SECM,SPCM
33700 WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33701 ENDIF
33702
33703 IF(NPART.LT.0) RETURN
33704
33705 IF(NPART.GE.1) CALL PHO_PRSTRG
33706
33707 WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33708 ICHAS = 0
33709 IBARFS = 0
33710 IMULC = 0
33711 IMUL = 0
33712 WRITE(LO,'(/1X,A,A,/,1X,A,A)')
33713 & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
33714 & ' IH1 IH2 CO1 CO2',
33715 & '========================================================',
33716 & '===================='
33717 DO 20 IH=1,NHEP
33718 CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
33719 BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
33720 WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
33721 & IH,ISTHEP(IH),PHO_PNAME(IH,2),
33722 & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
33723 & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
33724 & ICOLOR(1,IH),ICOLOR(2,IH)
33725 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33726 ICHAS = ICHAS + IPHO_CHR3(IH,2)
33727 IBARFS = IBARFS + IPHO_BAR3(IH,2)
33728 ENDIF
33729 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33730 IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
33731 IMUL = IMUL+1
33732 ENDIF
33733 20 CONTINUE
33734 WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
33735 & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
33736
33737 WRITE(LO,7)
33738 PXS = 0.D0
33739 PYS = 0.D0
33740 PZS = 0.D0
33741 P0S = 0.D0
33742 DO 30 IN=1,NHEP
33743 IF( (ABS(PHEP(3,IN)).LT.99999.D0)
33744 & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
33745 WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33746 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33747 ELSE
33748 WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33749 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33750 ENDIF
33751 IF(ABS(ISTHEP(IN)).EQ.1) THEN
33752 PXS = PXS + PHEP(1,IN)
33753 PYS = PYS + PHEP(2,IN)
33754 PZS = PZS + PHEP(3,IN)
33755 P0S = P0S + PHEP(4,IN)
33756 ENDIF
33757 30 CONTINUE
33758 AMFS = P0S**2-PXS**2-PYS**2-PZS**2
33759 AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
33760 IF(P0S.LT.99999.D0) THEN
33761 WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33762 ELSE
33763 WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33764 ENDIF
33765 WRITE(LO,'(//)')
33766
33767 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
33768 & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
33769 & 8H CHARGE ,8H BARYON ,/)
33770 6 FORMAT(7I8,2F8.3)
33771 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
33772 & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
33773 & 2X,'-------------------------------',
33774 & '--------------------------------------------')
33775 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
33776 9 FORMAT(I10,14X,5F10.3)
33777 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
33778 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
33779 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
33780
33781 IF(NPART.GE.2) CALL PYLIST(1)
33782
33783 END
33784
33785CDECK ID>, PHO_LTRHEP
33786 SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
33787C*******************************************************************
33788C
33789C Lorentz transformation of entries I1 to I2 in /POEVT1/
33790C
33791C********************************************************************
33792 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33793 SAVE
33794
33795 PARAMETER ( DIFF = 0.001D0,
33796 & EPS = 1.D-5 )
33797
33798C input/output channels
33799 INTEGER LI,LO
33800 COMMON /POINOU/ LI,LO
33801C event debugging information
33802 INTEGER NMAXD
33803 PARAMETER (NMAXD=100)
33804 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33805 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33806 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33807 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33808
33809C standard particle data interface
33810 INTEGER NMXHEP
33811
33812 PARAMETER (NMXHEP=4000)
33813
33814 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33815 DOUBLE PRECISION PHEP,VHEP
33816 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33817 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33818 & VHEP(4,NMXHEP)
33819C extension to standard particle data interface (PHOJET specific)
33820 INTEGER IMPART,IPHIST,ICOLOR
33821 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33822
33823 DO 100 I=I1,MIN(I2,NHEP)
33824 IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
33825 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33826 & XX,YY,ZZ)
33827 EE=PHEP(4,I)
33828 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33829 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
33830 ELSE IF(ISTHEP(I).EQ.20) THEN
33831 EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
33832 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33833 & XX,YY,ZZ)
33834 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33835 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
33836 ENDIF
33837 100 CONTINUE
33838
33839C debug precision
33840 IF(IDEB(70).LT.1) RETURN
33841 DO 200 I=I1,MIN(NHEP,I2)
33842 IF(ABS(ISTHEP(I)).GT.10) GOTO 190
33843 PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
33844 PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
33845 IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
33846 WRITE(LO,'(1X,A,I5,2E13.4)')
33847 & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
33848 ENDIF
33849 190 CONTINUE
33850 200 CONTINUE
33851
33852 END
33853
33854CDECK ID>, PHO_PECMS
33855 SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
33856C*******************************************************************
33857C
33858C calculation of cms momentum and energy of massive particle
33859C (ID= 1 using PMASS1, 2 using PMASS2)
33860C
33861C output: PP cms momentum
33862C EE energy in CMS of particle ID
33863C
33864C********************************************************************
33865 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33866 SAVE
33867
33868C input/output channels
33869 INTEGER LI,LO
33870 COMMON /POINOU/ LI,LO
33871C event debugging information
33872 INTEGER NMAXD
33873 PARAMETER (NMAXD=100)
33874 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33875 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33876 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33877 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33878C some constants
33879 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
33880 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
33881 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
33882
33883 S=ECM**2
33884 PM1 = SIGN(PMASS1**2,PMASS1)
33885 PM2 = SIGN(PMASS2**2,PMASS2)
33886 PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
33887 & + PM1**2 + PM2**2)/(2.D0*ECM)
33888
33889 IF(ID.EQ.1) THEN
33890 EE = SQRT( PM1 + PP**2 )
33891 ELSE IF(ID.EQ.2) THEN
33892 EE = SQRT( PM2 + PP**2 )
33893 ELSE
33894 WRITE(LO,'(/1X,A,I3,/)')
33895 & 'PHO_PECMS:ERROR: invalid ID number:',ID
33896 EE = PP
33897 ENDIF
33898
33899 END
33900
33901CDECK ID>, PHO_FRAINI
33902 SUBROUTINE PHO_FRAINI(IDEFAU)
33903C***********************************************************************
33904C
33905C initialization of fragmentation packages
33906C (currently LUND JETSET)
33907C
33908C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
33909C changed to work in PHOJET (R.E. 1/94)
33910C
33911C input: IDEFAU 0 no hadronization at all
33912C 1 do not touch any parameter of JETSET
33913C 2 default parameters kept, decay length 10mm to
33914C define stable particles
33915C 3 load tuned parameters for JETSET 7.3
33916C neg. value: prevent strange/charm hadrons from decaying
33917C
33918C***********************************************************************
33919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33920 SAVE
33921
33922 PARAMETER (EPS=1.D-10)
33923
33924C input/output channels
33925 INTEGER LI,LO
33926 COMMON /POINOU/ LI,LO
33927
33928 INTEGER N,NPAD,K
33929 DOUBLE PRECISION P,V
33930 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33931
33932 INTEGER MSTU,MSTJ
33933 DOUBLE PRECISION PARU,PARJ
33934 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33935
33936 INTEGER KCHG
33937 DOUBLE PRECISION PMAS,PARF,VCKM
33938 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33939
33940 INTEGER MDCY,MDME,KFDP
33941 DOUBLE PRECISION BRAT
33942 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
33943
33944 INTEGER PYCOMP
33945
33946 IDEFAB = ABS(IDEFAU)
33947
33948 IF(IDEFAB.EQ.0) THEN
33949 WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
33950 RETURN
33951 ENDIF
33952C defaults
33953 DEF2 = PARJ(2)
33954 IDEF12 = MSTJ(12)
33955 DEF19 = PARJ(19)
33956 DEF41 = PARJ(41)
33957 DEF42 = PARJ(42)
33958 DEF21 = PARJ(21)
33959
33960C declare stable particles
33961 IF(IDEFAB.GE.2) MSTJ(22) = 2
33962
33963C load optimized parameters
33964 IF(IDEFAB.GE.3) THEN
33965
33966* PARJ(19)=0.19
33967C Lund a-parameter
33968C (default=0.3)
33969 PARJ(41)=0.3
33970C Lund b-parameter
33971C (default=1.0)
33972 PARJ(42)=1.0
33973C Lund sigma parameter in pt distribution
33974C (default=0.36)
33975 PARJ(21)=0.36
33976 ENDIF
33977C
33978C prevent particles decaying
33979 IF(IDEFAU.LT.0) THEN
33980C K0S
33981
33982 KC=PYCOMP(310)
33983
33984 MDCY(KC,1)=0
33985C PI0
33986
33987 KC=PYCOMP(111)
33988
33989 MDCY(KC,1)=0
33990C LAMBDA
33991
33992 KC=PYCOMP(3122)
33993
33994 MDCY(KC,1)=0
33995C ALAMBDA
33996
33997 KC=PYCOMP(-3122)
33998
33999 MDCY(KC,1)=0
34000C SIG+
34001
34002 KC=PYCOMP(3222)
34003
34004 MDCY(KC,1)=0
34005C ASIG+
34006
34007 KC=PYCOMP(-3222)
34008
34009 MDCY(KC,1)=0
34010C SIG-
34011
34012 KC=PYCOMP(3112)
34013
34014 MDCY(KC,1)=0
34015C ASIG-
34016
34017 KC=PYCOMP(-3112)
34018
34019 MDCY(KC,1)=0
34020C SIG0
34021
34022 KC=PYCOMP(3212)
34023
34024 MDCY(KC,1)=0
34025C ASIG0
34026
34027 KC=PYCOMP(-3212)
34028
34029 MDCY(KC,1)=0
34030C TET0
34031
34032 KC=PYCOMP(3322)
34033
34034 MDCY(KC,1)=0
34035C ATET0
34036
34037 KC=PYCOMP(-3322)
34038
34039 MDCY(KC,1)=0
34040C TET-
34041
34042 KC=PYCOMP(3312)
34043
34044 MDCY(KC,1)=0
34045C ATET-
34046
34047 KC=PYCOMP(-3312)
34048
34049 MDCY(KC,1)=0
34050C OMEGA-
34051
34052 KC=PYCOMP(3334)
34053
34054 MDCY(KC,1)=0
34055C AOMEGA-
34056
34057 KC=PYCOMP(-3334)
34058
34059 MDCY(KC,1)=0
34060C D+
34061
34062 KC=PYCOMP(411)
34063
34064 MDCY(KC,1)=0
34065C D-
34066
34067 KC=PYCOMP(-411)
34068
34069 MDCY(KC,1)=0
34070C D0
34071
34072 KC=PYCOMP(421)
34073
34074 MDCY(KC,1)=0
34075C A-D0
34076
34077 KC=PYCOMP(-421)
34078
34079 MDCY(KC,1)=0
34080C DS+
34081
34082 KC=PYCOMP(431)
34083
34084 MDCY(KC,1)=0
34085C A-DS+
34086
34087 KC=PYCOMP(-431)
34088
34089 MDCY(KC,1)=0
34090C ETAC
34091
34092 KC=PYCOMP(441)
34093
34094 MDCY(KC,1)=0
34095C LAMBDAC+
34096
34097 KC=PYCOMP(4122)
34098
34099 MDCY(KC,1)=0
34100C A-LAMBDAC+
34101
34102 KC=PYCOMP(-4122)
34103
34104 MDCY(KC,1)=0
34105C SIGMAC++
34106
34107 KC=PYCOMP(4222)
34108
34109 MDCY(KC,1)=0
34110C SIGMAC+
34111
34112 KC=PYCOMP(4212)
34113
34114 MDCY(KC,1)=0
34115C SIGMAC0
34116
34117 KC=PYCOMP(4112)
34118
34119 MDCY(KC,1)=0
34120C A-SIGMAC++
34121
34122 KC=PYCOMP(-4222)
34123
34124 MDCY(KC,1)=0
34125C A-SIGMAC+
34126
34127 KC=PYCOMP(-4212)
34128
34129 MDCY(KC,1)=0
34130C A-SIGMAC0
34131
34132 KC=PYCOMP(-4112)
34133
34134 MDCY(KC,1)=0
34135C KSIC+
34136
34137 KC=PYCOMP(4232)
34138
34139 MDCY(KC,1)=0
34140C KSIC0
34141
34142 KC=PYCOMP(4132)
34143
34144 MDCY(KC,1)=0
34145C A-KSIC+
34146
34147 KC=PYCOMP(-4232)
34148
34149 MDCY(KC,1)=0
34150C A-KSIC0
34151
34152 KC=PYCOMP(-4132)
34153
34154 MDCY(KC,1)=0
34155 ENDIF
34156
34157C *** Commented by Chiara
34158C WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34159C & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34160C 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34161C & ' --------------------------------------------------',/,
34162C & 5X,'parameter description default / current',/,
34163C & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34164C & 5X,'MSTJ(12) popcorn : ',2I7,/,
34165C & 5X,'PARJ(19) popcorn : ',2F7.3,/,
34166C & 5X,'PARJ(41) Lund a : ',2F7.3,/,
34167C & 5X,'PARJ(42) Lund b : ',2F7.3,/,
34168C & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34169
34170 END
34171
34172CDECK ID>, PHO_SETPAR
34173 SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34174C**********************************************************************
34175C
34176C assign a particle to either side 1 or 2
34177C (including special treatment for remnants)
34178C
34179C input: Iside 1,2 side selected for the particle
34180C -2 output of current settings
34181C IDpdg PDG number
34182C IDcpc CPC number
34183C 0 CPC determination in subroutine
34184C -1 special particle remnant, IDPDG
34185C is the particle number the remnant
34186C corresponds to (see /POHDFL/)
34187C
34188C**********************************************************************
34189
34190 IMPLICIT NONE
34191
34192 SAVE
34193
34194 integer Iside,IDpdg,IDcpc
34195 double precision Pvir
34196
34197C input/output channels
34198 INTEGER LI,LO
34199 COMMON /POINOU/ LI,LO
34200C event debugging information
34201 INTEGER NMAXD
34202 PARAMETER (NMAXD=100)
34203 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34204 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34205 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34206 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34207C global event kinematics and particle IDs
34208 INTEGER IFPAP,IFPAB
34209 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34210 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34211C nucleon-nucleus / nucleus-nucleus interface to DPMJET
34212 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34213 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34214 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34215 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34216C particle ID translation table
34217 integer ID_pdg_list,ID_list,ID_pdg_max
34218 character*12 name_list
34219 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34220 & ID_pdg_max
34221C general particle data
34222 double precision xm_list,tau_list,gam_list,
34223 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34224 & xm_bb82_list,xm_bb102_list
34225 integer ich3_list,iba3_list,iq_list,
34226 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
34227 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34228 & xm_psm2_list(6,6),xm_vem2_list(6,6),
34229 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34230 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34231 & ich3_list(300),iba3_list(300),iq_list(3,300),
34232 & id_psm_list(6,6),id_vem_list(6,6),
34233 & id_b8_list(6,6,6),id_b10_list(6,6,6)
34234C particle decay data
34235 double precision wg_sec_list
34236 integer idec_list,isec_list
34237 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34238 & isec_list(3,500)
34239
34240C external functions
34241 integer ipho_pdg2id,ipho_chr3,ipho_bar3
34242 double precision pho_pmass
34243
34244C local variables
34245 integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34246
34247 IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34248 IDcpcN = IDcpc
34249C remnant?
34250 IF(IDcpc.EQ.-1) THEN
34251 IF(Iside.EQ.1) THEN
34252 IDpdgR = 81
34253 ELSE
34254 IDpdgR = 82
34255 ENDIF
34256 IDcpcR = ipho_pdg2id(IDpdgR)
34257 IDEQB(Iside) = ipho_pdg2id(IDpdg)
34258 IDEQP(Iside) = IDpdg
34259C copy particle properties
34260 IDB = abs(IDEQB(Iside))
34261 xm_list(IDcpcR) = xm_list(IDB)
34262 tau_list(IDcpcR) = tau_list(IDB)
34263 gam_list(IDcpcR) = gam_list(IDB)
34264 IF(IHFLS(Iside).EQ.1) THEN
34265 ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34266 iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34267 ELSE
34268 ich3_list(IDcpcR) = 0
34269 iba3_list(IDcpcR) = 0
34270 ENDIF
34271C quark content
34272 IFL1 = IHFLD(Iside,1)
34273 IFL2 = IHFLD(Iside,2)
34274 IFL3 = 0
34275 IF(IHFLS(Iside).EQ.1) THEN
34276 IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34277 IFL1 = IHFLD(Iside,1)/1000
34278 IFL2 = MOD(IHFLD(Iside,1)/100,10)
34279 IFL3 = IHFLD(Iside,2)
34280 ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34281 IFL1 = IHFLD(Iside,1)
34282 IFL2 = IHFLD(Iside,2)/1000
34283 IFL3 = MOD(IHFLD(Iside,2)/100,10)
34284 ENDIF
34285 ENDIF
34286 iq_list(1,IDcpcR) = IFL1
34287 iq_list(2,IDcpcR) = IFL2
34288 iq_list(3,IDcpcR) = IFL3
34289
34290 IDcpcN = IDcpcR
34291 IDPDGN = IDPDGR
34292
34293 IF(IDEB(87).GE.5) THEN
34294 WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34295 & 'pho_setpar: remnant assignment side',Iside,
34296 & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34297 ENDIF
34298 ELSE IF(IDcpc.EQ.0) THEN
34299C ordinary hadron
34300 IHFLS(Iside) = 1
34301 IHFLD(Iside,1) = 0
34302 IHFLD(Iside,2) = 0
34303 IDcpcN = ipho_pdg2id(IDpdg)
34304 IDpdgN = IDpdg
34305 ENDIF
34306
34307C initialize /POGCMS/
34308 IFPAP(Iside) = IDpdgN
34309 IFPAB(Iside) = IDcpcN
34310 PMASS(Iside) = pho_pmass(IDcpcN,0)
34311 IF(IFPAP(Iside).EQ.22) THEN
34312 PVIRT(Iside) = ABS(PVIR)
34313 ELSE
34314 PVIRT(Iside) = 0.D0
34315 ENDIF
34316
34317 ELSE IF(Iside.EQ.-2) THEN
34318C output of current settings
34319 DO 100 I=1,2
34320 WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34321 & 'PHO_SETPAR: side',
34322 & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34323 & PVIRT(I)
34324 IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34325 WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34326 & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34327 & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34328 ENDIF
34329 100 CONTINUE
34330 ELSE
34331 WRITE(LO,'(/1X,A,I8)')
34332 & 'pho_setpar: invalid argument (Iside)',Iside
34333 ENDIF
34334
34335 END
34336
34337CDECK ID>, PHO_XLAM
34338 DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34339C**********************************************************************
34340C
34341C auxiliary function for two/three particle decay mode
34342C (standard LAMBDA**(1/2) function)
34343C
34344C**********************************************************************
34345 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34346 SAVE
34347C
34348 YZ=Y-Z
34349 XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34350 IF(XLAM.LT.0.D0) XLAM=-XLAM
34351 PHO_XLAM=SQRT(XLAM)
34352 END
34353
34354CDECK ID>, PHO_BESSJ0
34355 DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34356C**********************************************************************
34357C
34358C CERN (KERN) LIB function C312
34359C
34360C modified by R. Engel (03/02/93)
34361C
34362C**********************************************************************
34363 DOUBLE PRECISION DX
34364 DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34365 DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34366 SAVE
34367
34368 DATA EIGHT /8.0D0/
34369 DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34370
34371 DATA C1( 0) /+0.15772 79714 7489D0/
34372 DATA C1( 1) /-0.00872 34423 5285D0/
34373 DATA C1( 2) /+0.26517 86132 0334D0/
34374 DATA C1( 3) /-0.37009 49938 7265D0/
34375 DATA C1( 4) /+0.15806 71023 3210D0/
34376 DATA C1( 5) /-0.03489 37694 1141D0/
34377 DATA C1( 6) /+0.00481 91800 6947D0/
34378 DATA C1( 7) /-0.00046 06261 6621D0/
34379 DATA C1( 8) /+0.00003 24603 2882D0/
34380 DATA C1( 9) /-0.00000 17619 4691D0/
34381 DATA C1(10) /+0.00000 00760 8164D0/
34382 DATA C1(11) /-0.00000 00026 7925D0/
34383 DATA C1(12) /+0.00000 00000 7849D0/
34384 DATA C1(13) /-0.00000 00000 0194D0/
34385 DATA C1(14) /+0.00000 00000 0004D0/
34386
34387 DATA C2( 0) /+0.99946 03493 4752D0/
34388 DATA C2( 1) /-0.00053 65220 4681D0/
34389 DATA C2( 2) /+0.00000 30751 8479D0/
34390 DATA C2( 3) /-0.00000 00517 0595D0/
34391 DATA C2( 4) /+0.00000 00016 3065D0/
34392 DATA C2( 5) /-0.00000 00000 7864D0/
34393 DATA C2( 6) /+0.00000 00000 0517D0/
34394 DATA C2( 7) /-0.00000 00000 0043D0/
34395 DATA C2( 8) /+0.00000 00000 0004D0/
34396 DATA C2( 9) /-0.00000 00000 0001D0/
34397
34398 DATA C3( 0) /-0.01555 58546 05337D0/
34399 DATA C3( 1) /+0.00006 83851 99426D0/
34400 DATA C3( 2) /-0.00000 07414 49841D0/
34401 DATA C3( 3) /+0.00000 00179 72457D0/
34402 DATA C3( 4) /-0.00000 00007 27192D0/
34403 DATA C3( 5) /+0.00000 00000 42201D0/
34404 DATA C3( 6) /-0.00000 00000 03207D0/
34405 DATA C3( 7) /+0.00000 00000 00301D0/
34406 DATA C3( 8) /-0.00000 00000 00033D0/
34407 DATA C3( 9) /+0.00000 00000 00004D0/
34408 DATA C3(10) /-0.00000 00000 00001D0/
34409
34410 X=DX
34411 V=ABS(X)
34412 IF(V .LT. EIGHT) THEN
34413 Y=V/EIGHT
34414 H=2.D0*Y**2-1.D0
34415 ALFA=-2.D0*H
34416 B1=0.D0
34417 B2=0.D0
34418 DO 1 I = 14,0,-1
34419 B0=C1(I)-ALFA*B1-B2
34420 B2=B1
34421 1 B1=B0
34422 B1=B0-H*B2
34423 ELSE
34424 R=1.D0/V
34425 Y=EIGHT*R
34426 H=2.D0*Y**2-1.D0
34427 ALFA=-2.D0*H
34428 B1=0.D0
34429 B2=0.D0
34430 DO 2 I = 9,0,-1
34431 B0=C2(I)-ALFA*B1-B2
34432 B2=B1
34433 2 B1=B0
34434 P=B0-H*B2
34435 B1=0.D0
34436 B2=0.D0
34437 DO 3 I = 10,0,-1
34438 B0=C3(I)-ALFA*B1-B2
34439 B2=B1
34440 3 B1=B0
34441 Q=Y*(B0-H*B2)
34442 B0=V-PI2
34443 B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34444 ENDIF
34445 PHO_BESSJ0=B1
34446 RETURN
34447 END
34448
34449CDECK ID>, PHO_BESSI0
34450 DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34451C**********************************************************************
34452C
34453C Bessel Function I0
34454C
34455C**********************************************************************
34456 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34457 SAVE
34458
34459 AX = ABS(X)
34460 IF (AX .LT. 3.75D0) THEN
34461 Y = (X/3.75D0)**2
34462 PHO_BESSI0 =
34463 & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34464 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34465 ELSE
34466 Y = 3.75D0/AX
34467 PHO_BESSI0 =
34468 & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34469 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34470 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34471 & +Y*0.392377D-2))))))))
34472 ENDIF
34473
34474 END
34475
34476CDECK ID>, PHO_BESSI1
34477 DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34478C**********************************************************************
34479C
34480C Bessel Function I1
34481C
34482C**********************************************************************
34483 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34484 SAVE
34485
34486 AX = ABS(X)
34487
34488 IF (AX .LT. 3.75D0) THEN
34489 Y = (X/3.75D0)**2
34490 BESLI1 =
34491 & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34492 & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34493 ELSE
34494 Y = 3.75D0/AX
34495 BESLI1 =
34496 & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34497 & -Y*0.420059D-2))
34498 BESLI1 =
34499 & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34500 & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34501 BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34502 ENDIF
34503 IF (X .LT. 0.D0) BESLI1 = -BESLI1
34504
34505 PHO_BESSI1 = BESLI1
34506
34507 END
34508
34509CDECK ID>, PHO_BESSK0
34510 DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34511C**********************************************************************
34512C
34513C Modified Bessel Function K0
34514C
34515C**********************************************************************
34516 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34517 SAVE
34518
34519 IF (X .LT. 2.D0) THEN
34520 Y = X**2/4.D0
34521 PHO_BESSK0 =
34522 & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34523 & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34524 & +Y*(0.10750D-3+Y*0.740D-5))))))
34525 ELSE
34526 Y = 2.D0/X
34527 PHO_BESSK0 =
34528 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34529 & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34530 & +Y*(-0.251540D-2+Y*0.53208D-3))))))
34531 ENDIF
34532
34533 END
34534
34535CDECK ID>, PHO_BESSK1
34536 DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34537C**********************************************************************
34538C
34539C Modified Bessel Function K1
34540C
34541C**********************************************************************
34542 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34543 SAVE
34544
34545 IF (X .LT. 2.D0) THEN
34546 Y = X**2/4.D0
34547 PHO_BESSK1 =
34548 & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34549 & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34550 & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34551 ELSE
34552 Y=2.D0/X
34553 PHO_BESSK1 =
34554 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34555 & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34556 & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34557 ENDIF
34558
34559 END
34560
34561CDECK ID>, PHO_GAUSET
34562 SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34563C********************************************************************
34564C
34565C N-point gauss zeros and weights for the interval (AX,BX) are
34566C stored in arrays Z and W respectively.
34567C
34568C*********************************************************************
34569 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34570 SAVE
34571
34572 COMMON /POGDAT/A(273),X(273),KTAB(96)
34573 DIMENSION Z(NX),W(NX)
34574
34575 ALPHA=0.5*(BX+AX)
34576 BETA=0.5*(BX-AX)
34577 N=NX
34578
34579C the N=1 case:
34580 IF(N.NE.1) GO TO 1
34581 Z(1)=ALPHA
34582 W(1)=BX-AX
34583 RETURN
34584
34585C the Gauss cases:
34586 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34587 IF(N.EQ.20) GO TO 2
34588 IF(N.EQ.24) GO TO 2
34589 IF(N.EQ.32) GO TO 2
34590 IF(N.EQ.40) GO TO 2
34591 IF(N.EQ.48) GO TO 2
34592 IF(N.EQ.64) GO TO 2
34593 IF(N.EQ.80) GO TO 2
34594 IF(N.EQ.96) GO TO 2
34595
34596C the extended Gauss cases:
34597 IF((N/96)*96.EQ.N) GO TO 3
34598
34599C jump to center of intervall intrgration:
34600 GO TO 100
34601
34602C get Gauss point array
34603
34604 2 CALL PHO_GAUDAT
34605C extract real points
34606 K=KTAB(N)
34607 M=N/2
34608 DO 21 J=1,M
34609C extract values from big array
34610 JTAB=K-1+J
34611 WTEMP=BETA*A(JTAB)
34612 DELTA=BETA*X(JTAB)
34613C store them backward
34614 Z(J)=ALPHA-DELTA
34615 W(J)=WTEMP
34616C store them forward
34617 JP=N+1-J
34618 Z(JP)=ALPHA+DELTA
34619 W(JP)=WTEMP
34620 21 CONTINUE
34621C store central point (odd N)
34622 IF((N-M-M).EQ.0) RETURN
34623 Z(M+1)=ALPHA
34624 JMID=K+M
34625 W(M+1)=BETA*A(JMID)
34626 RETURN
34627
34628C get ND96 times chained 96 Gauss point array
34629
34630 3 CALL PHO_GAUDAT
34631C print out message
34632C -extract real points
34633 K=KTAB(96)
34634 ND96=N/96
34635 DO 31 J=1,48
34636C extract values from big array
34637 JTAB=K-1+J
34638 WTEMP=BETA*A(JTAB)
34639 DELTA=BETA*X(JTAB)
34640 WTeMP=WTEMP/ND96
34641 DeLTA=DELTA/ND96
34642 DO 32 JD96=0,ND96-1
34643 ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34644C store them backward
34645 Z(J+JD96*96)=ZCNTR-DELTA
34646 W(J+JD96*96)=WTEMP
34647C store them forward
34648 JP=96+1-J
34649 Z(JP+JD96*96)=ZCNTR+DELTA
34650 W(JP+JD96*96)=WTEMP
34651 32 CONTINUE
34652 31 CONTINUE
34653 RETURN
34654
34655C the center of intervall cases:
34656 100 CONTINUE
34657C put in constant weight and equally spaced central points
34658 N=IABS(N)
34659 DO 111 IN=1,N
34660 WIN=(BX-AX)/FLOAT(N)
34661 Z(IN)=AX + (FLOAT(IN)-.5)*WIN
34662 111 W(IN)=WIN
34663
34664 END
34665
34666CDECK ID>, PHO_GAUDAT
34667 SUBROUTINE PHO_GAUDAT
34668C*********************************************************************
34669C
34670C store big arrays needed for Gauss integral, CERNLIB D106BD
34671C (arrays A,X,ITAB copied on B,Y,LTAB)
34672C
34673C*********************************************************************
34674 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34675
34676 SAVE
34677 COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34678 DIMENSION A(273),X(273),KTAB(96)
34679
34680C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34681 DATA KTAB(2)/1/
34682 DATA KTAB(3)/2/
34683 DATA KTAB(4)/4/
34684 DATA KTAB(5)/6/
34685 DATA KTAB(6)/9/
34686 DATA KTAB(7)/12/
34687 DATA KTAB(8)/16/
34688 DATA KTAB(9)/20/
34689 DATA KTAB(10)/25/
34690 DATA KTAB(11)/30/
34691 DATA KTAB(12)/36/
34692 DATA KTAB(13)/42/
34693 DATA KTAB(14)/49/
34694 DATA KTAB(15)/56/
34695 DATA KTAB(16)/64/
34696 DATA KTAB(20)/72/
34697 DATA KTAB(24)/82/
34698 DATA KTAB(28)/82/
34699 DATA KTAB(32)/94/
34700 DATA KTAB(36)/94/
34701 DATA KTAB(40)/110/
34702 DATA KTAB(44)/110/
34703 DATA KTAB(48)/130/
34704 DATA KTAB(52)/130/
34705 DATA KTAB(56)/130/
34706 DATA KTAB(60)/130/
34707 DATA KTAB(64)/154/
34708 DATA KTAB(68)/154/
34709 DATA KTAB(72)/154/
34710 DATA KTAB(76)/154/
34711 DATA KTAB(80)/186/
34712 DATA KTAB(84)/186/
34713 DATA KTAB(88)/186/
34714 DATA KTAB(92)/186/
34715 DATA KTAB(96)/226/
34716C
34717C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
34718C
34719C-----N=2
34720 DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
34721C-----N=3
34722 DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
34723 DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
34724C-----N=4
34725 DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
34726 DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
34727C-----N=5
34728 DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
34729 DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
34730 DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
34731C-----N=6
34732 DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
34733 DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
34734 DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
34735C-----N=7
34736 DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
34737 DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
34738 DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
34739 DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
34740C-----N=8
34741 DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
34742 DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
34743 DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
34744 DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
34745C-----N=9
34746 DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
34747 DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
34748 DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
34749 DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
34750 DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
34751C-----N=10
34752 DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
34753 DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
34754 DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
34755 DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
34756 DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
34757C-----N=11
34758 DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
34759 DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
34760 DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
34761 DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
34762 DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
34763 DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
34764C-----N=12
34765 DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
34766 DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
34767 DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
34768 DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
34769 DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
34770 DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
34771C-----N=13
34772 DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
34773 DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
34774 DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
34775 DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
34776 DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
34777 DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
34778 DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
34779C-----N=14
34780 DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
34781 DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
34782 DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
34783 DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
34784 DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
34785 DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
34786 DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
34787C-----N=15
34788 DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
34789 DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
34790 DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
34791 DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
34792 DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
34793 DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
34794 DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
34795 DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
34796C-----N=16
34797 DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
34798 DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
34799 DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
34800 DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
34801 DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
34802 DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
34803 DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
34804 DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
34805C-----N=20
34806 DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
34807 DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
34808 DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
34809 DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
34810 DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
34811 DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
34812 DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
34813 DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
34814 DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
34815 DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
34816C-----N=24
34817 DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
34818 DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
34819 DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
34820 DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
34821 DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
34822 DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
34823 DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
34824 DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
34825 DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
34826 DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
34827 DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
34828 DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
34829C-----N=32
34830 DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
34831 DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
34832 DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
34833 DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
34834 DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
34835 DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
34836 DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
34837 DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
34838 DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
34839 DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
34840 DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
34841 DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
34842 DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
34843 DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
34844 DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
34845 DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
34846C-----N=40
34847 DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
34848 DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
34849 DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
34850 DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
34851 DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
34852 DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
34853 DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
34854 DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
34855 DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
34856 DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
34857 DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
34858 DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
34859 DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
34860 DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
34861 DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
34862 DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
34863 DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
34864 DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
34865 DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
34866 DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
34867C-----N=48
34868 DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
34869 DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
34870 DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
34871 DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
34872 DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
34873 DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
34874 DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
34875 DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
34876 DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
34877 DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
34878 DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
34879 DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
34880 DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
34881 DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
34882 DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
34883 DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
34884 DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
34885 DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
34886 DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
34887 DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
34888 DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
34889 DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
34890 DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
34891 DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
34892C-----N=64
34893 DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
34894 DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
34895 DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
34896 DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
34897 DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
34898 DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
34899 DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
34900 DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
34901 DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
34902 DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
34903 DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
34904 DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
34905 DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
34906 DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
34907 DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
34908 DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
34909 DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
34910 DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
34911 DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
34912 DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
34913 DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
34914 DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
34915 DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
34916 DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
34917 DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
34918 DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
34919 DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
34920 DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
34921 DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
34922 DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
34923 DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
34924 DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
34925C-----N=80
34926 DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
34927 DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
34928 DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
34929 DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
34930 DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
34931 DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
34932 DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
34933 DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
34934 DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
34935 DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
34936 DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
34937 DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
34938 DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
34939 DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
34940 DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
34941 DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
34942 DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
34943 DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
34944 DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
34945 DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
34946 DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
34947 DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
34948 DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
34949 DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
34950 DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
34951 DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
34952 DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
34953 DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
34954 DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
34955 DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
34956 DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
34957 DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
34958 DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
34959 DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
34960 DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
34961 DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
34962 DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
34963 DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
34964 DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
34965 DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
34966C-----N=96
34967 DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
34968 DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
34969 DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
34970 DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
34971 DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
34972 DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
34973 DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
34974 DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
34975 DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
34976 DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
34977 DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
34978 DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
34979 DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
34980 DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
34981 DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
34982 DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
34983 DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
34984 DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
34985 DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
34986 DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
34987 DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
34988 DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
34989 DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
34990 DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
34991 DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
34992 DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
34993 DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
34994 DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
34995 DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
34996 DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
34997 DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
34998 DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
34999 DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
35000 DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
35001 DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
35002 DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
35003 DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
35004 DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
35005 DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
35006 DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
35007 DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
35008 DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
35009 DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
35010 DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
35011 DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
35012 DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
35013 DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
35014 DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
35015 DATA IBD/0/
35016 IF(IBD.NE.0) RETURN
35017 IBD=1
35018 DO 10 I=1,273
35019 B(I) = A(I)
35020 Y(I) = X(I)
35021 10 CONTINUE
35022 DO 20 I=1,96
35023 LTAB(I) = KTAB(I)
35024 20 CONTINUE
35025 END
35026
35027CDECK ID>, PHO_DZEROX
35028 DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
35029C**********************************************************************
35030C
35031C Based on
35032C
35033C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
35034C Guaranteed Convergence for Finding a Zero of a Function,
35035C ACM Trans. Math. Software 1 (1975) 330-345.
35036C
35037C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
35038C
35039C CERNLIB C200
35040C
35041C***********************************************************************
35042 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35043 SAVE
35044
35045C input/output channels
35046 INTEGER LI,LO
35047 COMMON /POINOU/ LI,LO
35048
35049 CHARACTER NAME*(*)
35050 PARAMETER (NAME = 'PHO_DZEROX')
35051 LOGICAL LMT
35052 DIMENSION IM1(2),IM2(2),LMT(2)
35053 EXTERNAL F
35054
35055 PARAMETER (Z1 = 1, HALF = Z1/2)
35056
35057 DATA IM1 /2,3/, IM2 /-1,3/
35058
35059 IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
35060 C=-2D+10
35061 WRITE(LO,100) NAME,MODE
35062 GO TO 99
35063 ENDIF
35064 FA=F(B0)
35065 FB=F(A0)
35066 IF(FA*FB .GT. 0) THEN
35067 C=-3D+10
35068 WRITE(LO,101) NAME
35069 GO TO 99
35070 ENDIF
35071 ATL=ABS(EPS)
35072 B=A0
35073 A=B0
35074 LMT(2)=.TRUE.
35075 MF=2
35076 1 C=A
35077 FC=FA
35078 2 IE=0
35079 3 IF(ABS(FC) .LT. ABS(FB)) THEN
35080 IF(C .NE. A) THEN
35081 D=A
35082 FD=FA
35083 END IF
35084 A=B
35085 B=C
35086 C=A
35087 FA=FB
35088 FB=FC
35089 FC=FA
35090 END IF
35091 TOL=ATL*(1+ABS(C))
35092 H=HALF*(C+B)
35093 HB=H-B
35094 IF(ABS(HB) .GT. TOL) THEN
35095 IF(IE .GT. IM1(MODE)) THEN
35096 W=HB
35097 ELSE
35098 TOL=TOL*SIGN(Z1,HB)
35099 P=(B-A)*FB
35100 LMT(1)=IE .LE. 1
35101 IF(LMT(MODE)) THEN
35102 Q=FA-FB
35103 LMT(2)=.FALSE.
35104 ELSE
35105 FDB=(FD-FB)/(D-B)
35106 FDA=(FD-FA)/(D-A)
35107 P=FDA*P
35108 Q=FDB*FA-FDA*FB
35109 END IF
35110 IF(P .LT. 0) THEN
35111 P=-P
35112 Q=-Q
35113 END IF
35114 IF(IE .EQ. IM2(MODE)) P=P+P
35115 IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
35116 W=TOL
35117 ELSEIF(P .LT. HB*Q) THEN
35118 W=P/Q
35119 ELSE
35120 W=HB
35121 END IF
35122 END IF
35123 D=A
35124 A=B
35125 FD=FA
35126 FA=FB
35127 B=B+W
35128 MF=MF+1
35129 IF(MF .GT. MAXF) THEN
35130 WRITE(LO,102) NAME
35131 GO TO 99
35132 ENDIF
35133 FB=F(B)
35134 IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35135 IF(W .EQ. HB) GO TO 2
35136 IE=IE+1
35137 GO TO 3
35138 END IF
35139 99 CONTINUE
35140 PHO_DZEROX=C
35141 RETURN
35142 100 FORMAT(1X,A,': mode = ',I3,' illegal')
35143 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35144 102 FORMAT(1X,A,': too many function calls')
35145
35146 END
35147
35148CDECK ID>, PHO_EXPINT
35149 DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35150C***********************************************************************
35151C
35152C function to calculate E_i(x) = -E_1(-x)
35153C
35154C based on CERNLIB C337 (changed by R.Engel 10/1993)
35155C
35156C***********************************************************************
35157 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35158 SAVE
35159
35160C input/output channels
35161 INTEGER LI,LO
35162 COMMON /POINOU/ LI,LO
35163
35164 DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35165 DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35166 DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35167
35168 DATA X0 /0.37250 74107 8137D0/
35169 DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35170 DATA P1
35171 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35172 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35173 3 -4.34981 43832 952D+2/
35174 DATA Q1
35175 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35176 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35177 3 +7.53585 64359 843D+2/
35178 DATA P2
35179 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35180 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35181 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35182 4 +4.65627 10797 510D-7/
35183 DATA Q2
35184 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35185 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35186 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35187 4 +1.00000 00000 000D+0/
35188 DATA P3
35189 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35190 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35191 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35192 DATA Q3
35193 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35194 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35195 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35196 DATA P4
35197 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35198 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35199 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35200 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35201 DATA Q4
35202 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35203 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35204 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35205 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35206 DATA A1
35207 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35208 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35209 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35210 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35211 DATA B1
35212 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35213 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35214 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35215 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35216 DATA A2
35217 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35218 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35219 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35220 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35221 DATA B2
35222 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35223 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35224 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35225 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35226 DATA A3
35227 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35228 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35229 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35230 DATA B3
35231 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35232 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35233 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35234C
35235C conversion to E_i function
35236 X = -RXM
35237C
35238 IF(X .LE. XL(1)) THEN
35239 AP=A3(1)-X
35240 DO 1 I = 2,5
35241 1 AP=A3(I)-X+B3(I)/AP
35242 Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35243 ELSEIF(X .LE. XL(2)) THEN
35244 AP=A2(1)-X
35245 DO 2 I = 2,7
35246 2 AP=A2(I)-X+B2(I)/AP
35247 Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35248 ELSEIF(X .LE. XL(3)) THEN
35249 AP=A1(1)-X
35250 DO 3 I = 2,7
35251 3 AP=A1(I)-X+B1(I)/AP
35252 Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35253 ELSEIF(X .LT. XL(4)) THEN
35254 V=-2.D0*(X/3.D0+1.D0)
35255 BP=0.D0
35256 DP=P4(1)
35257 DO 4 I = 2,8
35258 AP=BP
35259 BP=DP
35260 4 DP=P4(I)-AP+V*BP
35261 BQ=0.D0
35262 DQ=Q4(1)
35263 DO 14 I = 2,8
35264 AQ=BQ
35265 BQ=DQ
35266 14 DQ=Q4(I)-AQ+V*BQ
35267 Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35268 ELSEIF(X .EQ. XL(4)) THEN
35269* CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35270* IF(MFLAG) THEN
35271* IF(LGFILE .EQ. 0) THEN
35272* WRITE(LO,100) ENAME
35273* ELSE
35274* WRITE(LGFILE,100) ENAME
35275* ENDIF
35276* ENDIF
35277* IF(.NOT.RFLAG) CALL ABEND
35278 PHO_EXPINT=0.D0
35279 RETURN
35280 ELSEIF(X .LT. XL(5)) THEN
35281 AP=P1(1)
35282 AQ=Q1(1)
35283 DO 5 I = 2,5
35284 AP=P1(I)+X*AP
35285 5 AQ=Q1(I)+X*AQ
35286 Y=-LOG(X)+AP/AQ
35287 ELSEIF(X .LE. XL(6)) THEN
35288 Y=1.D0/X
35289 AP=P2(1)
35290 AQ=Q2(1)
35291 DO 6 I = 2,7
35292 AP=P2(I)+Y*AP
35293 6 AQ=Q2(I)+Y*AQ
35294 Y=EXP(-X)*AP/AQ
35295 ELSE
35296 Y=1.D0/X
35297 AP=P3(1)
35298 AQ=Q3(1)
35299 DO 7 I = 2,6
35300 AP=P3(I)+Y*AP
35301 7 AQ=Q3(I)+Y*AQ
35302 Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35303 ENDIF
35304C sign conversion to E_i
35305 PHO_EXPINT=-Y
35306
35307 END
35308
35309CDECK ID>, PHO_RNDBET
35310 DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35311C********************************************************************
35312C
35313C RANDOM NUMBER GENERATION FROM BETA
35314C DISTRIBUTION IN REGION 0 < X < 1.
35315C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35316C *GAMM(ETA))
35317C
35318C********************************************************************
35319 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35320 SAVE
35321
35322 Y = PHO_RNDGAM(1.D0,GAM)
35323 Z = PHO_RNDGAM(1.D0,ETA)
35324
35325 PHO_RNDBET = Y/(Y+Z)
35326
35327 END
35328
35329CDECK ID>, PHO_RNDGAM
35330 DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35331C********************************************************************
35332C
35333C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35334C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35335C
35336C********************************************************************
35337 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35338 SAVE
35339C
35340 NCOU=0
35341 N = ETA
35342 F = ETA - N
35343 IF(F.EQ.0.D0) GOTO 20
35344 10 R = DT_RNDM(ETA)
35345 NCOU=NCOU+1
35346 IF (NCOU.GE.11) GOTO 20
35347 IF(R.LT.F/(F+2.71828D0)) GOTO 30
35348 YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35349 IF(ABS(YYY).GT.50.D0) GOTO 20
35350 Y = EXP(YYY)
35351 IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35352 GOTO 40
35353 20 Y = 0.D0
35354 GOTO 50
35355 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35356 IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35357 40 IF(N.EQ.0) GOTO 70
35358 50 Z = 1.D0
35359 DO 60 I = 1,N
35360 60 Z = Z*DT_RNDM(Y)
35361 Y = Y-LOG(Z+1.0D-9)
35362 70 PHO_RNDGAM = Y/ALAM
35363 RETURN
35364 END
35365
35366CDECK ID>, PHO_SFECFE
35367 SUBROUTINE PHO_SFECFE(SFE,CFE)
35368C**********************************************************************
35369C
35370C fast random SIN(X) COS(X) selection
35371C
35372C**********************************************************************
35373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35374 SAVE
35375C
35376 1 CONTINUE
35377 X=DT_RNDM(XX)
35378 Y=DT_RNDM(YY)
35379 XX=X*X
35380 YY=Y*Y
35381 XY=XX+YY
35382 IF(XY.GT.1.D0) GOTO 1
35383 CFE=(XX-YY)/XY
35384 SFE=2.D0*X*Y/XY
35385 IF(DT_RNDM(XY).LT.0.5D0) THEN
35386 SFE=-SFE
35387 ENDIF
35388 END
35389
35390CDECK ID>, PHO_SWAPD
35391 SUBROUTINE PHO_SWAPD(D1,D2)
35392C********************************************************************
35393C
35394C exchange of argument values (double precision)
35395C
35396C********************************************************************
35397 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35398 D = D1
35399 D1 = D2
35400 D2 = D
35401 END
35402
35403CDECK ID>, PHO_SWAPI
35404 SUBROUTINE PHO_SWAPI(I1,I2)
35405C********************************************************************
35406C
35407C exchange of argument values (integer)
35408C
35409C********************************************************************
35410 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35411 K = I1
35412 I1 = I2
35413 I2 = K
35414 END
35415
35416CDECK ID>, PHO_HADCSL
35417 SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35418 & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35419C***********************************************************************
35420C
35421C low-energy cross section parametrizations
35422C
35423C input: ID1,ID2 PDG IDs of particles (meson first)
35424C ECM c.m. energy (GeV)
35425C PLAB lab. momentum (second particle at rest)
35426C IMODE 1 ECM given, PLAB ignored
35427C 2 PLAB given, ECM ignored
35428C
35429C output: SIGTOT total cross section (mb)
35430C SIGEL elastic cross section (mb)
35431C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
35432C SLOPE forward elastic slope (GeV**-2)
35433C RHO real/imaginary part of elastic amplitude
35434C
35435C comments:
35436C
35437C - low-energy data interpolation uses PDG fits from 1992 issue
35438C - high-energy extrapolation by Donnachie-Landshoff like fit made
35439C by PDG 1996
35440C - analytic extension of amplitude to calculate rho
35441C
35442C***********************************************************************
35443
35444 IMPLICIT NONE
35445
35446 SAVE
35447
35448 INTEGER ID1,ID2,IMODE
35449 DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35450
35451C input/output channels
35452 INTEGER LI,LO
35453 COMMON /POINOU/ LI,LO
35454C some constants
35455 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35456 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35457 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35458C model switches and parameters
35459 CHARACTER*8 MDLNA
35460 INTEGER ISWMDL,IPAMDL
35461 DOUBLE PRECISION PARMDL
35462 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35463
35464 INTEGER K
35465 DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35466 & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35467
35468 DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35469
35470 DATA TPDG92 /
35471 & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35472 & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35473 & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35474 & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35475 & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35476 & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35477 & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35478 & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35479 & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35480 & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35481 & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35482 & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
35483
35484 DATA TPDG96 /
35485 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35486 & 77.15D0,-21.05D0,0.46D0,0.9D0,
35487 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35488 & 77.15D0,21.05D0,0.46D0,0.9D0,
35489 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35490 & 31.85D0,-4.05D0,0.45D0,0.9D0,
35491 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35492 & 31.85D0,4.05D0,0.45D0,0.9D0,
35493 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35494 & 17.35D0,-9.05D0,0.50D0,0.9D0,
35495 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35496 & 17.35D0,9.05D0,0.50D0,0.9D0 /
35497
35498 DATA BURQ83 /
35499 & 11.13D0, -6.21D0, 0.30D0,
35500 & 11.13D0, 7.23D0, 0.30D0,
35501 & 9.11D0, -0.73D0, 0.28D0,
35502 & 9.11D0, 0.65D0, 0.28D0,
35503 & 8.55D0, -5.98D0, 0.28D0,
35504 & 8.55D0, 1.60D0, 0.28D0 /
35505
35506 DATA XMA /
35507 & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35508
35509C find index
35510 IF(ID2.NE.2212) THEN
35511 GOTO 100
35512 ELSE IF(ID1.EQ.2212) THEN
35513 K = 1
35514 ELSE IF(ID1.EQ.-2212) THEN
35515 K = 2
35516 ELSE IF(ID1.EQ.211) THEN
35517 K = 3
35518 ELSE IF(ID1.EQ.-211) THEN
35519 K = 4
35520 ELSE IF(ID1.EQ.321) THEN
35521 K = 5
35522 ELSE IF(ID1.EQ.-321) THEN
35523 K = 6
35524 ELSE
35525 GOTO 100
35526 ENDIF
35527
35528C calculate lab momentum
35529 IF(IMODE.EQ.1) THEN
35530 SS = ECM**2
35531 E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35532 PL = SQRT(E1*E1-XMA(K)**2)
35533 ELSE IF(IMODE.EQ.2) THEN
35534 PL = PLAB
35535 SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35536 ECM = SQRT(SS)
35537 ELSE
35538 WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35539 RETURN
35540 ENDIF
35541 PLL = LOG(PL)
35542
35543C check against lower limit
35544 IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35545
35546 XP = TPDG96(2,K)*SS**TPDG96(3,K)
35547 YP = TPDG96(6,K)/SS**TPDG96(8,K)
35548 YM = TPDG96(7,K)/SS**TPDG96(8,K)
35549
35550 PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35551 PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35552 RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35553 SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35554
35555C select energy range and interpolation method
35556 IF(PL.LT.TPDG96(1,K)) THEN
35557 SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35558 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35559 SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35560 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35561 ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35562 SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35563 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35564 SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35565 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35566 SIGTO2 = YP+YM+XP
35567 SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35568 X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35569 X1 = 1.D0 - X2
35570 SIGTOT = SIGTO2*X2 + SIGTO1*X1
35571 SIGEL = SIGEL2*X2 + SIGEL1*X1
35572 ELSE
35573 SIGTOT = YP+YM+XP
35574 SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35575 ENDIF
35576
35577C no parametrization of diffraction implemented
35578 SIGDIF(1) = -1.D0
35579 SIGDIF(2) = -1.D0
35580 SIGDIF(3) = -1.D0
35581
35582 RETURN
35583
35584 100 CONTINUE
35585 WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35586 & 'invalid particle combination: ',ID1,ID2
35587 RETURN
35588
35589 200 CONTINUE
35590 WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35591 & 'energy too small (Ecm,Plab): ',ECM,PLAB
35592
35593 END
35594
35595CDECK ID>, PHO_CSDIFF
35596 SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35597 & sig_sd1,sig_sd2,sig_dd)
35598C***********************************************************************
35599C
35600C cross section for diffraction dissociation according to
35601C Goulianos' parametrization (Ref: PL B358 (1995) 379)
35602C
35603C in addition rescaling for different particles is applied using
35604C internal rescaling tables (not implemented yet)
35605C
35606C input: Id1/2 PDG ID's of incoming particles
35607C SS squared c.m. energy (GeV**2)
35608C Xi_min min. diff mass (squared) = Xi_min*SS
35609C Xi_max max. diff mass (squared) = Xi_max*SS
35610C
35611C output: sig_sd1 cross section for diss. of particle 1 (mb)
35612C sig_sd2 cross section for diss. of particle 2 (mb)
35613C sig_dd cross section for diss. of both particles
35614C
35615C***********************************************************************
35616
35617 IMPLICIT NONE
35618
35619 SAVE
35620
35621 INTEGER Id1,Id2
35622 DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35623
35624C input/output channels
35625 INTEGER LI,LO
35626 COMMON /POINOU/ LI,LO
35627C some constants
35628 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35629 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35630 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35631
35632 DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35633 DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35634 & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35635 & xms_1,xms_2,CSdiff
35636
35637 INTEGER Ngau1,Ngau2,i1,i2
35638
35639C model parameters
35640
35641 DATA delta / 0.104d0 /
35642 DATA alphap / 0.25d0 /
35643 DATA beta0 / 6.56d0 /
35644 DATA gpom0 / 1.21d0 /
35645 DATA xm_p / 0.938d0 /
35646 DATA x_rad2 / 0.71d0 /
35647
35648C integration precision
35649
35650 DATA Ngau1 / 96 /
35651 DATA Ngau2 / 96 /
35652
35653 sig_sd1 = 0.d0
35654 sig_sd2 = 0.d0
35655 sig_dd = 0.d0
35656
35657 IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35658
35659 xm4_p2 = 4.D0*xm_p**2
35660 fac = beta0**2/(16.D0*PI)
35661
35662 t1 = -5.D0
35663 t2 = 0.D0
35664 tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35665 tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35666
35667C flux renormalization and cross section
35668
35669 Xnorm = 0.d0
35670
35671 xil = log(1.5d0/SS)
35672 xiu = log(0.1d0)
35673
35674 IF(xiu.LE.xil) goto 1000
35675
35676 CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
35677 CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
35678
35679 do i1=1,Ngau1
35680
35681 xi = exp(xpos1(i1))
35682 w_xi = Xwgh1(i1)
35683
35684 do i2=1,Ngau2
35685
35686 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35687
35688 alpha_t = 1.D0+delta+alphap*tt
35689 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35690
35691 Xnorm = Xnorm
35692 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35693
35694 enddo
35695 enddo
35696
35697 Xnorm = Xnorm*fac
35698
35699 1000 continue
35700
35701 XIL = LOG(Xi_min)
35702 XIU = LOG(Xi_max)
35703
35704 T1 = -5.D0
35705 T2 = 0.D0
35706
35707 TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35708 TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35709
35710C single diffraction diss. cross section
35711
35712 CSdiff = 0.d0
35713
35714 IF(XIU.LE.XIL) goto 2000
35715
35716 CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
35717 CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
35718
35719 do i1=1,Ngau1
35720
35721 xi = exp(xpos1(i1))
35722 w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
35723
35724 do i2=1,Ngau2
35725
35726 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35727
35728 alpha_t = 1.D0+delta+alphap*tt
35729 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35730
35731 CSdiff = CSdiff
35732 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35733
35734 enddo
35735 enddo
35736
35737 CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
35738
35739* WRITE(LO,'(1x,1p,4e14.3)')
35740* & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
35741
35742 sig_sd1 = CSdiff
35743 sig_sd2 = CSdiff
35744
35745 2000 continue
35746
35747C double diffraction dissociation cross section
35748
35749 CSdiff = 0.d0
35750
35751 xil = log(1.5d0/SS)
35752 xiu = log(Xi_max/1.5d0)
35753
35754 IF(xiu.LE.xil) goto 3000
35755
35756 fac = (beta0*gpom0*SS**delta
35757 & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
35758 & /(2.d0*alphap)
35759
35760 CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
35761
35762 do i1=1,Ngau1
35763
35764 xi = exp(xpos1(i1))
35765 xms_1 = xi*SS
35766
35767 xiu = log(Xi_max/(xi*SS))
35768
35769 if(xil.lt.xiu) then
35770
35771 CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
35772
35773 do i2=1,Ngau2
35774
35775 xms_2 = exp(xpos2(i2))*SS
35776 CSdiff = CSdiff
35777 & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
35778 & *xwgh1(i1)*xwgh2(i2)
35779
35780 enddo
35781
35782 endif
35783
35784 enddo
35785
35786 sig_dd = CSdiff*fac*GEV2MB
35787
35788 3000 continue
35789
35790 ELSE
35791
35792 WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
35793 & 'invalid particle combination (Id1/2)',Id1,Id2
35794
35795 ENDIF
35796
35797 END
35798
35799CDECK ID>, PHO_ALLM97
35800 DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
35801C**********************************************************************
35802C
35803C ALLM97 parametrization for gamma*-p cross section
35804C (for F2 see comments, code adapted from V. Shekelyan, H1)
35805C
35806C**********************************************************************
35807
35808 IMPLICIT NONE
35809
35810 SAVE
35811
35812C input/output channels
35813 INTEGER LI,LO
35814 COMMON /POINOU/ LI,LO
35815
35816 DOUBLE PRECISION Q2,W
35817 DOUBLE PRECISION M02,M12,LAM2,M22
35818 DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
35819 DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
35820 DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
35821 & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
35822 DATA ALFA,XMP2 /112.2D0 , .8802D0 /
35823
35824 W2=W*W
35825 PHO_ALLM97 = 0.D0
35826
35827C pomeron
35828 S11 = 0.28067D0
35829 S12 = 0.22291D0
35830 S13 = 2.1979D0
35831 A11 = -0.0808D0
35832 A12 = -0.44812D0
35833 A13 = 1.1709D0
35834 B11 = 0.60243D0
35835 B12 = 1.3754D0
35836 B13 = 1.8439D0
35837 M12 = 49.457D0
35838
35839C reggeon
35840 S21 = 0.80107D0
35841 S22 = 0.97307D0
35842 S23 = 3.4942D0
35843 A21 = 0.58400D0
35844 A22 = 0.37888D0
35845 A23 = 2.6063D0
35846 B21 = 0.10711D0
35847 B22 = 1.9386D0
35848 B23 = 0.49338D0
35849 M22 = 0.15052D0
35850C
35851 M02 = 0.31985D0
35852 LAM2 = 0.065270D0
35853 Q02 = 0.46017D0 +LAM2
35854
35855C
35856 S=0.
35857 T=LOG((Q2+Q02)/LAM2)
35858 T0=LOG(Q02/LAM2)
35859 IF(Q2.GT.0.D0) S=LOG(T/T0)
35860 Z=1.D0
35861
35862 IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
35863
35864 IF(S.LT.0.01D0) THEN
35865
35866C pomeron part
35867
35868 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35869
35870 AP=A11
35871 BP=B11**2
35872
35873 SP=S11
35874 F2P=SP*XP**AP*Z**BP
35875
35876C reggeon part
35877
35878 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35879
35880 AR=A21
35881 BR=B21**2
35882
35883 SR=S21
35884 F2R=SR*XR**AR*Z**BR
35885
35886 ELSE
35887
35888C pomeron part
35889
35890 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35891
35892 AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
35893
35894 BP=B11**2+B12**2*S**B13
35895
35896 SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
35897
35898 F2P=SP*XP**AP*Z**BP
35899
35900C reggeon part
35901
35902 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35903
35904 AR=A21+A22*S**A23
35905 BR=B21**2+B22**2*S**B23
35906
35907 SR=S21+S22*S**S23
35908 F2R=SR*XR**AR*Z**BR
35909
35910 ENDIF
35911
35912* F2 = (F2P+F2R)*Q2/(Q2+M02)
35913
35914 CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
35915 PHO_ALLM97 = CIN*(F2P+F2R)
35916
35917 END
35918
35919CDECK ID>, PHO_DOR98LO
35920 SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
35921C***********************************************************************
35922C
35923C GRV98 parton densities, leading order set
35924C
35925C For a detailed explanation see
35926C M. Glueck, E. Reya, A. Vogt :
35927C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
35928C (To appear in Eur. Phys. J. C)
35929C
35930C interpolation routine based on the original GRV98PA routine,
35931C adapted to define interpolation table as DATA statements
35932C
35933C (R.Engel, 09/98)
35934C
35935C
35936C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
35937C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
35938C
35939C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
35940C DS = d(bar), SS = s = s(bar), GL = gluon.
35941C Always x times the distribution is returned.
35942C
35943C******************************************************i****************
35944 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
35945 SAVE
35946
35947C input/output channels
35948 INTEGER LI,LO
35949 COMMON /POINOU/ LI,LO
35950
35951 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
35952 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
35953 1 XSF(NX,NQ), XGF(NX,NQ),
35954 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
35955
35956 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
35957 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
35958
35959 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
35960 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
35961 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
35962 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
35963 EQUIVALENCE (XSF(1,1),XSF_L(1))
35964 EQUIVALENCE (XGF(1,1),XGF_L(1))
35965
35966 DATA (ARRF(K),K= 1, 95) /
35967 & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
35968 & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
35969 & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
35970 & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
35971 & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
35972 & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
35973 & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
35974 & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
35975 & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
35976 & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
35977 & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
35978 & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
35979 & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
35980 & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
35981 & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
35982 & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
35983 & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
35984 & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
35985 & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
35986 DATA (XUVF_L(K),K= 1, 114) /
35987 &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
35988 &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
35989 &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
35990 &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
35991 &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
35992 &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
35993 &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
35994 &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
35995 &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
35996 &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
35997 &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
35998 &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
35999 &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
36000 &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
36001 &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
36002 &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
36003 &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
36004 &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
36005 &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
36006 DATA (XUVF_L(K),K= 115, 228) /
36007 &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
36008 &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
36009 &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
36010 &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
36011 &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
36012 &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
36013 &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
36014 &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
36015 &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
36016 &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
36017 &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
36018 &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
36019 &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
36020 &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
36021 &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
36022 &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
36023 &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
36024 &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
36025 &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
36026 DATA (XUVF_L(K),K= 229, 342) /
36027 &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
36028 &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
36029 &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
36030 &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
36031 &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
36032 &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
36033 &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
36034 &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
36035 &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
36036 &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
36037 &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
36038 &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
36039 &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
36040 &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
36041 &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
36042 &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
36043 &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
36044 &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
36045 &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
36046 DATA (XUVF_L(K),K= 343, 456) /
36047 &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
36048 &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
36049 &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
36050 &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
36051 &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
36052 &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
36053 &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
36054 &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
36055 &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
36056 &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
36057 &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
36058 &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
36059 &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
36060 &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
36061 &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
36062 &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
36063 &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
36064 &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
36065 &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
36066 DATA (XUVF_L(K),K= 457, 570) /
36067 &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
36068 &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
36069 &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
36070 &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
36071 &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
36072 &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
36073 &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
36074 &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
36075 &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
36076 &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
36077 &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
36078 &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
36079 &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
36080 &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
36081 &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
36082 &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
36083 &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
36084 &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
36085 &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
36086 DATA (XUVF_L(K),K= 571, 684) /
36087 &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
36088 &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
36089 &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
36090 &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
36091 &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
36092 &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
36093 &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
36094 &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
36095 &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
36096 &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
36097 &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
36098 &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
36099 &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
36100 &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
36101 &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
36102 &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
36103 &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
36104 &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
36105 &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
36106 DATA (XUVF_L(K),K= 685, 798) /
36107 &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
36108 &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36109 &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36110 &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36111 &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36112 &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36113 &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36114 &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36115 &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36116 &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36117 &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36118 &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36119 &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36120 &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36121 &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36122 &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36123 &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36124 &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36125 &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36126 DATA (XUVF_L(K),K= 799, 912) /
36127 &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36128 &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36129 &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36130 &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36131 &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36132 &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36133 &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36134 &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36135 &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36136 &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36137 &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36138 &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36139 &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36140 &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36141 &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36142 &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36143 &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36144 &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36145 &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36146 DATA (XUVF_L(K),K= 913, 1026) /
36147 &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36148 &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36149 &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36150 &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36151 &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36152 &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36153 &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36154 &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36155 &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36156 &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36157 &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36158 &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36159 &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36160 &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36161 &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36162 &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36163 &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36164 &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36165 &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36166 DATA (XUVF_L(K),K= 1027, 1140) /
36167 &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36168 &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36169 &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36170 &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36171 &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36172 &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36173 &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36174 &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36175 &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36176 &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36177 &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36178 &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36179 &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36180 &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36181 &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36182 &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36183 &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36184 &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36185 &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36186 DATA (XUVF_L(K),K= 1141, 1254) /
36187 &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36188 &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36189 &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36190 &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36191 &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36192 &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36193 &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36194 &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36195 &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36196 &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36197 &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36198 &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36199 &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36200 &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36201 &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36202 &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36203 &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36204 &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36205 &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36206 DATA (XUVF_L(K),K= 1255, 1368) /
36207 &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36208 &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36209 &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36210 &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36211 &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36212 &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36213 &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36214 &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36215 &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36216 &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36217 &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36218 &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36219 &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36220 &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36221 &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36222 &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36223 &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36224 &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36225 &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36226 DATA (XUVF_L(K),K= 1369, 1482) /
36227 &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36228 &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36229 &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36230 &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36231 &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36232 &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36233 &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36234 &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36235 &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36236 &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36237 &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36238 &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36239 &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36240 &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36241 &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36242 &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36243 &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36244 &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36245 &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36246 DATA (XUVF_L(K),K= 1483, 1596) /
36247 &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36248 &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36249 &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36250 &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36251 &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36252 &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36253 &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36254 &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36255 &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36256 &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36257 &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36258 &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36259 &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36260 &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36261 &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36262 &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36263 &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36264 &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36265 &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36266 DATA (XUVF_L(K),K= 1597, 1710) /
36267 &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36268 &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36269 &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36270 &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36271 &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36272 &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36273 &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36274 &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36275 &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36276 &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36277 &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36278 &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36279 &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36280 &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36281 &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36282 &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36283 &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36284 &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36285 &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36286 DATA (XUVF_L(K),K= 1711, 1824) /
36287 &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36288 &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36289 &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36290 &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36291 &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36292 &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36293 &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36294 &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36295 &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36296 &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36297 &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36298 &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36299 &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36300 &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36301 &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36302 &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36303 &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36304 &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36305 &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36306 DATA (XUVF_L(K),K= 1825, 1836) /
36307 &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36308 &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36309 DATA (XDVF_L(K),K= 1, 114) /
36310 &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36311 &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36312 &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36313 &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36314 &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36315 &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36316 &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36317 &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36318 &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36319 &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36320 &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36321 &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36322 &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36323 &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36324 &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36325 &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36326 &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36327 &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36328 &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36329 DATA (XDVF_L(K),K= 115, 228) /
36330 &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36331 &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36332 &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36333 &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36334 &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36335 &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36336 &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36337 &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36338 &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36339 &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36340 &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36341 &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36342 &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36343 &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36344 &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36345 &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36346 &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36347 &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36348 &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36349 DATA (XDVF_L(K),K= 229, 342) /
36350 &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36351 &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36352 &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36353 &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36354 &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36355 &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36356 &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36357 &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36358 &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36359 &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36360 &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36361 &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36362 &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36363 &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36364 &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36365 &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36366 &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36367 &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36368 &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36369 DATA (XDVF_L(K),K= 343, 456) /
36370 &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36371 &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36372 &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36373 &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36374 &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36375 &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36376 &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36377 &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36378 &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36379 &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36380 &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36381 &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36382 &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36383 &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36384 &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36385 &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36386 &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36387 &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36388 &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36389 DATA (XDVF_L(K),K= 457, 570) /
36390 &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36391 &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36392 &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36393 &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36394 &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36395 &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36396 &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36397 &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36398 &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36399 &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36400 &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36401 &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36402 &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36403 &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36404 &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36405 &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36406 &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36407 &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36408 &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36409 DATA (XDVF_L(K),K= 571, 684) /
36410 &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36411 &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36412 &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36413 &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36414 &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36415 &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36416 &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36417 &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36418 &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36419 &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36420 &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36421 &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36422 &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36423 &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36424 &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36425 &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36426 &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36427 &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36428 &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36429 DATA (XDVF_L(K),K= 685, 798) /
36430 &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36431 &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36432 &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36433 &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36434 &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36435 &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36436 &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36437 &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36438 &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36439 &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36440 &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36441 &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36442 &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36443 &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36444 &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36445 &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36446 &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36447 &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36448 &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36449 DATA (XDVF_L(K),K= 799, 912) /
36450 &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36451 &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36452 &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36453 &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36454 &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36455 &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36456 &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36457 &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36458 &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36459 &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36460 &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36461 &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36462 &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36463 &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36464 &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36465 &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36466 &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36467 &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36468 &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36469 DATA (XDVF_L(K),K= 913, 1026) /
36470 &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36471 &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36472 &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36473 &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36474 &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36475 &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36476 &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36477 &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36478 &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36479 &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36480 &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36481 &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36482 &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36483 &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36484 &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36485 &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36486 &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36487 &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36488 &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36489 DATA (XDVF_L(K),K= 1027, 1140) /
36490 &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36491 &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36492 &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36493 &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36494 &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36495 &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36496 &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36497 &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36498 &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36499 &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36500 &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36501 &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36502 &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36503 &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36504 &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36505 &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36506 &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36507 &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36508 &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36509 DATA (XDVF_L(K),K= 1141, 1254) /
36510 &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36511 &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36512 &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36513 &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36514 &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36515 &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36516 &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36517 &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36518 &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36519 &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36520 &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36521 &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36522 &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36523 &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36524 &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36525 &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36526 &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36527 &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36528 &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36529 DATA (XDVF_L(K),K= 1255, 1368) /
36530 &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36531 &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36532 &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36533 &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36534 &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36535 &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36536 &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36537 &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36538 &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36539 &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36540 &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36541 &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36542 &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36543 &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36544 &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36545 &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36546 &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36547 &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36548 &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36549 DATA (XDVF_L(K),K= 1369, 1482) /
36550 &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36551 &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36552 &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36553 &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36554 &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36555 &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36556 &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36557 &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36558 &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36559 &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36560 &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36561 &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36562 &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36563 &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36564 &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36565 &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36566 &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36567 &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36568 &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36569 DATA (XDVF_L(K),K= 1483, 1596) /
36570 &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36571 &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36572 &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36573 &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36574 &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36575 &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36576 &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36577 &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36578 &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36579 &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36580 &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36581 &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36582 &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36583 &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36584 &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36585 &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36586 &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36587 &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36588 &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36589 DATA (XDVF_L(K),K= 1597, 1710) /
36590 &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36591 &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36592 &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36593 &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36594 &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36595 &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36596 &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36597 &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36598 &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36599 &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36600 &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36601 &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36602 &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36603 &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36604 &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36605 &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36606 &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36607 &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36608 &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36609 DATA (XDVF_L(K),K= 1711, 1824) /
36610 &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36611 &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36612 &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36613 &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36614 &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36615 &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36616 &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36617 &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36618 &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36619 &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36620 &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36621 &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36622 &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36623 &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36624 &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36625 &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36626 &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36627 &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36628 &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36629 DATA (XDVF_L(K),K= 1825, 1836) /
36630 &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36631 &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36632 DATA (XDEF_L(K),K= 1, 114) /
36633 &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36634 &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36635 &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36636 &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36637 &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36638 &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36639 &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36640 &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36641 &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36642 &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36643 &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36644 &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36645 &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36646 &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36647 &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36648 &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36649 &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36650 &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36651 &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36652 DATA (XDEF_L(K),K= 115, 228) /
36653 &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36654 &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36655 &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36656 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36657 &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36658 &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36659 &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36660 &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36661 &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36662 &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36663 &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36664 &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36665 &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
36666 &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
36667 &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36668 &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
36669 &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
36670 &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
36671 &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
36672 DATA (XDEF_L(K),K= 229, 342) /
36673 &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
36674 &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
36675 &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
36676 &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
36677 &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
36678 &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
36679 &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
36680 &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
36681 &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
36682 &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
36683 &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
36684 &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
36685 &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
36686 &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
36687 &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
36688 &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
36689 &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
36690 &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
36691 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
36692 DATA (XDEF_L(K),K= 343, 456) /
36693 &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
36694 &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
36695 &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
36696 &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
36697 &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
36698 &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
36699 &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
36700 &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
36701 &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
36702 &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
36703 &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36704 &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
36705 &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
36706 &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
36707 &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
36708 &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
36709 &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
36710 &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
36711 &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
36712 DATA (XDEF_L(K),K= 457, 570) /
36713 &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
36714 &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
36715 &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36716 &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
36717 &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
36718 &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
36719 &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
36720 &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
36721 &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
36722 &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
36723 &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
36724 &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
36725 &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
36726 &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
36727 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
36728 &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
36729 &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
36730 &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
36731 &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
36732 DATA (XDEF_L(K),K= 571, 684) /
36733 &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
36734 &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
36735 &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
36736 &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
36737 &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
36738 &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
36739 &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36740 &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
36741 &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
36742 &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
36743 &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
36744 &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
36745 &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
36746 &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
36747 &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
36748 &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
36749 &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
36750 &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36751 &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
36752 DATA (XDEF_L(K),K= 685, 798) /
36753 &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
36754 &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
36755 &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
36756 &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
36757 &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
36758 &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
36759 &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
36760 &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
36761 &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
36762 &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
36763 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
36764 &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
36765 &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
36766 &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
36767 &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
36768 &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
36769 &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
36770 &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
36771 &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
36772 DATA (XDEF_L(K),K= 799, 912) /
36773 &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
36774 &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
36775 &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36776 &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
36777 &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
36778 &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
36779 &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
36780 &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
36781 &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
36782 &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
36783 &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
36784 &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
36785 &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
36786 &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36787 &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
36788 &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
36789 &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
36790 &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
36791 &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
36792 DATA (XDEF_L(K),K= 913, 1026) /
36793 &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
36794 &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
36795 &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
36796 &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
36797 &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
36798 &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
36799 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
36800 &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
36801 &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
36802 &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
36803 &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
36804 &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
36805 &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
36806 &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
36807 &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
36808 &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
36809 &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
36810 &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36811 &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
36812 DATA (XDEF_L(K),K= 1027, 1140) /
36813 &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
36814 &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
36815 &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
36816 &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
36817 &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
36818 &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
36819 &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
36820 &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
36821 &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
36822 &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36823 &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
36824 &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
36825 &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
36826 &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
36827 &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
36828 &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
36829 &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
36830 &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
36831 &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
36832 DATA (XDEF_L(K),K= 1141, 1254) /
36833 &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
36834 &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
36835 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
36836 &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
36837 &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
36838 &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
36839 &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
36840 &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
36841 &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
36842 &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
36843 &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
36844 &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
36845 &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
36846 &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36847 &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
36848 &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
36849 &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
36850 &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
36851 &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
36852 DATA (XDEF_L(K),K= 1255, 1368) /
36853 &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
36854 &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
36855 &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
36856 &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
36857 &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
36858 &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36859 &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
36860 &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
36861 &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
36862 &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
36863 &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
36864 &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
36865 &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
36866 &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
36867 &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
36868 &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
36869 &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
36870 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
36871 &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
36872 DATA (XDEF_L(K),K= 1369, 1482) /
36873 &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
36874 &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
36875 &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
36876 &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
36877 &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
36878 &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
36879 &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
36880 &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
36881 &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
36882 &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36883 &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
36884 &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
36885 &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
36886 &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
36887 &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
36888 &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
36889 &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
36890 &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
36891 &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
36892 DATA (XDEF_L(K),K= 1483, 1596) /
36893 &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
36894 &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36895 &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
36896 &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
36897 &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
36898 &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
36899 &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
36900 &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
36901 &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
36902 &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
36903 &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
36904 &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
36905 &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
36906 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
36907 &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
36908 &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
36909 &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
36910 &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
36911 &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
36912 DATA (XDEF_L(K),K= 1597, 1710) /
36913 &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
36914 &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
36915 &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
36916 &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
36917 &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
36918 &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36919 &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
36920 &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
36921 &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
36922 &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
36923 &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
36924 &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
36925 &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
36926 &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
36927 &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
36928 &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
36929 &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36930 &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
36931 &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
36932 DATA (XDEF_L(K),K= 1711, 1824) /
36933 &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
36934 &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
36935 &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
36936 &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
36937 &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
36938 &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
36939 &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
36940 &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
36941 &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
36942 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
36943 &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
36944 &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
36945 &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
36946 &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
36947 &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
36948 &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
36949 &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
36950 &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
36951 &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
36952 DATA (XDEF_L(K),K= 1825, 1836) /
36953 &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
36954 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
36955 DATA (XUDF_L(K),K= 1, 114) /
36956 &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
36957 &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
36958 &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
36959 &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
36960 &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
36961 &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
36962 &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
36963 &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
36964 &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
36965 &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
36966 &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
36967 &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
36968 &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
36969 &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
36970 &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
36971 &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
36972 &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
36973 &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
36974 &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
36975 DATA (XUDF_L(K),K= 115, 228) /
36976 &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
36977 &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
36978 &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
36979 &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
36980 &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
36981 &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
36982 &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
36983 &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
36984 &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
36985 &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
36986 &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
36987 &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
36988 &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
36989 &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
36990 &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
36991 &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
36992 &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
36993 &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
36994 &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
36995 DATA (XUDF_L(K),K= 229, 342) /
36996 &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
36997 &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
36998 &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
36999 &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
37000 &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
37001 &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
37002 &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
37003 &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
37004 &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
37005 &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
37006 &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
37007 &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
37008 &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
37009 &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
37010 &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
37011 &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
37012 &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
37013 &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
37014 &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
37015 DATA (XUDF_L(K),K= 343, 456) /
37016 &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
37017 &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
37018 &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
37019 &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
37020 &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
37021 &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
37022 &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
37023 &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
37024 &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
37025 &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
37026 &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
37027 &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
37028 &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
37029 &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
37030 &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
37031 &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
37032 &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
37033 &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
37034 &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
37035 DATA (XUDF_L(K),K= 457, 570) /
37036 &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
37037 &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
37038 &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
37039 &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
37040 &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
37041 &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
37042 &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
37043 &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
37044 &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
37045 &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
37046 &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
37047 &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
37048 &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
37049 &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
37050 &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
37051 &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
37052 &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
37053 &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
37054 &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
37055 DATA (XUDF_L(K),K= 571, 684) /
37056 &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
37057 &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
37058 &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
37059 &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
37060 &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
37061 &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
37062 &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
37063 &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
37064 &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
37065 &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
37066 &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
37067 &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
37068 &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
37069 &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
37070 &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
37071 &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
37072 &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
37073 &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
37074 &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
37075 DATA (XUDF_L(K),K= 685, 798) /
37076 &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
37077 &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
37078 &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
37079 &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
37080 &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
37081 &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
37082 &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
37083 &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
37084 &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
37085 &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
37086 &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
37087 &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
37088 &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
37089 &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
37090 &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
37091 &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
37092 &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
37093 &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
37094 &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
37095 DATA (XUDF_L(K),K= 799, 912) /
37096 &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
37097 &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
37098 &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
37099 &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
37100 &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
37101 &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
37102 &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
37103 &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
37104 &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
37105 &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
37106 &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
37107 &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
37108 &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37109 &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37110 &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37111 &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37112 &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37113 &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37114 &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37115 DATA (XUDF_L(K),K= 913, 1026) /
37116 &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37117 &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37118 &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37119 &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37120 &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37121 &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37122 &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37123 &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37124 &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37125 &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37126 &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37127 &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37128 &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37129 &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37130 &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37131 &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37132 &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37133 &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37134 &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37135 DATA (XUDF_L(K),K= 1027, 1140) /
37136 &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37137 &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37138 &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37139 &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37140 &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37141 &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37142 &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37143 &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37144 &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37145 &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37146 &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37147 &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37148 &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37149 &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37150 &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37151 &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37152 &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37153 &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37154 &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37155 DATA (XUDF_L(K),K= 1141, 1254) /
37156 &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37157 &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37158 &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37159 &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37160 &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37161 &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37162 &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37163 &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37164 &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37165 &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37166 &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37167 &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37168 &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37169 &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37170 &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37171 &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37172 &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37173 &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37174 &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37175 DATA (XUDF_L(K),K= 1255, 1368) /
37176 &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37177 &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37178 &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37179 &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37180 &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37181 &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37182 &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37183 &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37184 &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37185 &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37186 &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37187 &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37188 &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37189 &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37190 &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37191 &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37192 &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37193 &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37194 &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37195 DATA (XUDF_L(K),K= 1369, 1482) /
37196 &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37197 &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37198 &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37199 &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37200 &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37201 &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37202 &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37203 &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37204 &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37205 &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37206 &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37207 &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37208 &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37209 &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37210 &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37211 &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37212 &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37213 &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37214 &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37215 DATA (XUDF_L(K),K= 1483, 1596) /
37216 &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37217 &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37218 &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37219 &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37220 &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37221 &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37222 &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37223 &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37224 &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37225 &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37226 &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37227 &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37228 &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37229 &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37230 &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37231 &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37232 &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37233 &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37234 &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37235 DATA (XUDF_L(K),K= 1597, 1710) /
37236 &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37237 &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37238 &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37239 &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37240 &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37241 &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37242 &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37243 &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37244 &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37245 &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37246 &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37247 &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37248 &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37249 &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37250 &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37251 &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37252 &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37253 &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37254 &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37255 DATA (XUDF_L(K),K= 1711, 1824) /
37256 &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37257 &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37258 &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37259 &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37260 &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37261 &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37262 &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37263 &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37264 &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37265 &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37266 &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37267 &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37268 &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37269 &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37270 &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37271 &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37272 &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37273 &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37274 &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37275 DATA (XUDF_L(K),K= 1825, 1836) /
37276 &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37277 &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37278 DATA (XSF_L(K),K= 1, 114) /
37279 &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37280 &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37281 &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37282 &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37283 &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37284 &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37285 &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37286 &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37287 &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37288 &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37289 &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37290 &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37291 &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37292 &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37293 &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37294 &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37295 &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37296 &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37297 &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37298 DATA (XSF_L(K),K= 115, 228) /
37299 &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37300 &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37301 &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37302 &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37303 &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37304 &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37305 &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37306 &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37307 &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37308 &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37309 &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37310 &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37311 &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37312 &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37313 &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37314 &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37315 &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37316 &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37317 &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37318 DATA (XSF_L(K),K= 229, 342) /
37319 &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37320 &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37321 &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37322 &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37323 &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37324 &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37325 &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37326 &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37327 &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37328 &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37329 &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37330 &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37331 &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37332 &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37333 &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37334 &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37335 &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37336 &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37337 &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37338 DATA (XSF_L(K),K= 343, 456) /
37339 &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37340 &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37341 &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37342 &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37343 &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37344 &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37345 &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37346 &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37347 &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37348 &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37349 &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37350 &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37351 &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37352 &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37353 &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37354 &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37355 &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37356 &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37357 &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37358 DATA (XSF_L(K),K= 457, 570) /
37359 &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37360 &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37361 &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37362 &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37363 &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37364 &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37365 &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37366 &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37367 &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37368 &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37369 &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37370 &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37371 &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37372 &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37373 &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37374 &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37375 &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37376 &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37377 &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37378 DATA (XSF_L(K),K= 571, 684) /
37379 &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37380 &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37381 &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37382 &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37383 &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37384 &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37385 &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37386 &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37387 &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37388 &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37389 &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37390 &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37391 &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37392 &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37393 &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37394 &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37395 &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37396 &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37397 &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37398 DATA (XSF_L(K),K= 685, 798) /
37399 &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37400 &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37401 &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37402 &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37403 &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37404 &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37405 &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37406 &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37407 &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37408 &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37409 &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37410 &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37411 &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37412 &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37413 &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37414 &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37415 &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37416 &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37417 &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37418 DATA (XSF_L(K),K= 799, 912) /
37419 &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37420 &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37421 &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37422 &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37423 &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37424 &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37425 &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37426 &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37427 &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37428 &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37429 &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37430 &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37431 &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37432 &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37433 &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37434 &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37435 &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37436 &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37437 &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37438 DATA (XSF_L(K),K= 913, 1026) /
37439 &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37440 &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37441 &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37442 &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37443 &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37444 &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37445 &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37446 &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37447 &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37448 &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37449 &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37450 &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37451 &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37452 &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37453 &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37454 &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37455 &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37456 &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37457 &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37458 DATA (XSF_L(K),K= 1027, 1140) /
37459 &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37460 &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37461 &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37462 &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37463 &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37464 &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37465 &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37466 &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37467 &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37468 &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37469 &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37470 &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37471 &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37472 &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37473 &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37474 &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37475 &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37476 &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37477 &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37478 DATA (XSF_L(K),K= 1141, 1254) /
37479 &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37480 &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37481 &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37482 &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37483 &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37484 &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37485 &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37486 &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37487 &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37488 &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37489 &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37490 &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37491 &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37492 &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37493 &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37494 &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37495 &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37496 &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37497 &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37498 DATA (XSF_L(K),K= 1255, 1368) /
37499 &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37500 &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37501 &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37502 &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37503 &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37504 &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37505 &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37506 &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37507 &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37508 &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37509 &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37510 &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37511 &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37512 &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37513 &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37514 &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37515 &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37516 &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37517 &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37518 DATA (XSF_L(K),K= 1369, 1482) /
37519 &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37520 &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37521 &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37522 &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37523 &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37524 &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37525 &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37526 &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37527 &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37528 &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37529 &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37530 &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37531 &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37532 &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37533 &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37534 &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37535 &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37536 &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37537 &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37538 DATA (XSF_L(K),K= 1483, 1596) /
37539 &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37540 &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37541 &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37542 &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37543 &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37544 &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37545 &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37546 &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37547 &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37548 &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37549 &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37550 &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37551 &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37552 &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37553 &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37554 &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37555 &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37556 &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37557 &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37558 DATA (XSF_L(K),K= 1597, 1710) /
37559 &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37560 &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37561 &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37562 &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37563 &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37564 &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37565 &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37566 &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37567 &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37568 &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37569 &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37570 &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37571 &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37572 &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37573 &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37574 &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37575 &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37576 &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37577 &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37578 DATA (XSF_L(K),K= 1711, 1824) /
37579 &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37580 &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37581 &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37582 &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37583 &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37584 &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37585 &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37586 &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37587 &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37588 &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37589 &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37590 &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37591 &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37592 &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37593 &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37594 &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37595 &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37596 &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37597 &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37598 DATA (XSF_L(K),K= 1825, 1836) /
37599 &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37600 &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37601 DATA (XGF_L(K),K= 1, 114) /
37602 &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37603 &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37604 &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37605 &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37606 &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37607 &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37608 &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37609 &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37610 &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37611 &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37612 &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37613 &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37614 &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37615 &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37616 &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37617 &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37618 &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37619 &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37620 &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37621 DATA (XGF_L(K),K= 115, 228) /
37622 &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37623 &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37624 &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37625 &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37626 &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37627 &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37628 &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37629 &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37630 &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37631 &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37632 &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37633 &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37634 &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37635 &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37636 &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37637 &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37638 &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37639 &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37640 &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37641 DATA (XGF_L(K),K= 229, 342) /
37642 &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37643 &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37644 &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37645 &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37646 &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37647 &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37648 &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37649 &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37650 &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37651 &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37652 &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37653 &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37654 &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37655 &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37656 &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37657 &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37658 &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37659 &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37660 &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37661 DATA (XGF_L(K),K= 343, 456) /
37662 &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37663 &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37664 &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37665 &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
37666 &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
37667 &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
37668 &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
37669 &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
37670 &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
37671 &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
37672 &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
37673 &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
37674 &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
37675 &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
37676 &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
37677 &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
37678 &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
37679 &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
37680 &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
37681 DATA (XGF_L(K),K= 457, 570) /
37682 &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
37683 &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
37684 &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
37685 &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
37686 &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
37687 &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
37688 &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
37689 &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
37690 &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
37691 &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
37692 &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
37693 &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
37694 &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
37695 &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
37696 &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
37697 &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
37698 &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
37699 &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
37700 &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
37701 DATA (XGF_L(K),K= 571, 684) /
37702 &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
37703 &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
37704 &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
37705 &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
37706 &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
37707 &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
37708 &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
37709 &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
37710 &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
37711 &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
37712 &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
37713 &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
37714 &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
37715 &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
37716 &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
37717 &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
37718 &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
37719 &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
37720 &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
37721 DATA (XGF_L(K),K= 685, 798) /
37722 &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
37723 &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
37724 &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
37725 &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
37726 &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
37727 &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
37728 &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
37729 &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
37730 &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
37731 &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
37732 &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
37733 &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
37734 &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
37735 &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
37736 &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
37737 &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
37738 &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
37739 &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
37740 &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
37741 DATA (XGF_L(K),K= 799, 912) /
37742 &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
37743 &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
37744 &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
37745 &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
37746 &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
37747 &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
37748 &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
37749 &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
37750 &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
37751 &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
37752 &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
37753 &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
37754 &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
37755 &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
37756 &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
37757 &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
37758 &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
37759 &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
37760 &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
37761 DATA (XGF_L(K),K= 913, 1026) /
37762 &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
37763 &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
37764 &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
37765 &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
37766 &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
37767 &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
37768 &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
37769 &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
37770 &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
37771 &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
37772 &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
37773 &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
37774 &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
37775 &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
37776 &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
37777 &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
37778 &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
37779 &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
37780 &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
37781 DATA (XGF_L(K),K= 1027, 1140) /
37782 &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
37783 &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
37784 &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
37785 &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
37786 &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
37787 &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
37788 &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
37789 &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
37790 &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
37791 &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
37792 &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
37793 &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
37794 &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
37795 &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
37796 &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
37797 &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
37798 &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
37799 &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
37800 &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
37801 DATA (XGF_L(K),K= 1141, 1254) /
37802 &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
37803 &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
37804 &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
37805 &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
37806 &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
37807 &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
37808 &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
37809 &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
37810 &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
37811 &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
37812 &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
37813 &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
37814 &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
37815 &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
37816 &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
37817 &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
37818 &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
37819 &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
37820 &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
37821 DATA (XGF_L(K),K= 1255, 1368) /
37822 &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
37823 &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
37824 &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
37825 &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
37826 &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
37827 &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
37828 &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
37829 &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
37830 &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
37831 &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
37832 &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
37833 &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
37834 &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
37835 &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
37836 &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
37837 &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
37838 &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
37839 &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
37840 &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
37841 DATA (XGF_L(K),K= 1369, 1482) /
37842 &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
37843 &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
37844 &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
37845 &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
37846 &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
37847 &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
37848 &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
37849 &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
37850 &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
37851 &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
37852 &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
37853 &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
37854 &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
37855 &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
37856 &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
37857 &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
37858 &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
37859 &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
37860 &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
37861 DATA (XGF_L(K),K= 1483, 1596) /
37862 &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
37863 &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
37864 &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
37865 &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
37866 &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
37867 &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
37868 &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
37869 &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
37870 &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
37871 &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
37872 &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
37873 &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
37874 &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
37875 &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
37876 &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
37877 &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
37878 &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
37879 &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
37880 &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
37881 DATA (XGF_L(K),K= 1597, 1710) /
37882 &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
37883 &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
37884 &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
37885 &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
37886 &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
37887 &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
37888 &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
37889 &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
37890 &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
37891 &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
37892 &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
37893 &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
37894 &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
37895 &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
37896 &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
37897 &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
37898 &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
37899 &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
37900 &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
37901 DATA (XGF_L(K),K= 1711, 1824) /
37902 &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
37903 &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
37904 &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
37905 &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
37906 &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
37907 &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
37908 &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
37909 &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
37910 &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
37911 &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
37912 &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
37913 &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
37914 &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
37915 &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
37916 &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
37917 &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
37918 &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
37919 &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
37920 &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
37921 DATA (XGF_L(K),K= 1825, 1836) /
37922 &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
37923 &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
37924
37925*
37926 X = Xinp
37927*...CHECK OF X AND Q2 VALUES :
37928 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37929* WRITE(LO,91) X
37930 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
37931 X = 0.99D-9
37932* STOP
37933 ENDIF
37934
37935 Q2 = Q2inp
37936 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37937* WRITE(LO,92) Q2
37938 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
37939 Q2 = 0.99E6
37940* STOP
37941 ENDIF
37942
37943*
37944*...INTERPOLATION :
37945 NA(1) = NX
37946 NA(2) = NQ
37947 XT(1) = DLOG(X)
37948 XT(2) = DLOG(Q2)
37949 X1 = 1.- X
37950 XV = X**0.5
37951 XS = X**(-0.2)
37952 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37953 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37954 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37955 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37956 US = 0.5 * (UD - DE)
37957 DS = 0.5 * (UD + DE)
37958 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
37959 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
37960
37961 END
37962
37963CDECK ID>, PHO_DOR98SC
37964 SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
37965C***********************************************************************
37966C
37967C GRV98 parton densities, leading order set
37968C
37969C For a detailed explanation see
37970C M. Glueck, E. Reya, A. Vogt :
37971C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
37972C (To appear in Eur. Phys. J. C)
37973C
37974C interpolation routine based on the original GRV98PA routine,
37975C adapted to define interpolation table as DATA statements
37976C
37977C (R.Engel, 09/98)
37978C
37979C CAUTION: this is a version with gluon shadowing corrections
37980C (R.Engel, 09/99)
37981C
37982C
37983C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
37984C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
37985C
37986C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
37987C DS = d(bar), SS = s = s(bar), GL = gluon.
37988C Always x times the distribution is returned.
37989C
37990C******************************************************i****************
37991 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
37992 SAVE
37993
37994C input/output channels
37995 INTEGER LI,LO
37996 COMMON /POINOU/ LI,LO
37997
37998 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
37999 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
38000 1 XSF(NX,NQ), XGF(NX,NQ),
38001 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
38002
38003 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
38004 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
38005
38006 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
38007 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
38008 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
38009 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
38010 EQUIVALENCE (XSF(1,1),XSF_L(1))
38011 EQUIVALENCE (XGF(1,1),XGF_L(1))
38012
38013*#################### data statements for shadowed LO PDF ##############
38014C ... deleted ...
38015*#######################################################################
38016
38017 X = Xinp
38018*...CHECK OF X AND Q2 VALUES :
38019 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
38020* WRITE(LO,91) X
38021 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
38022 X = 0.99D-9
38023* STOP
38024 ENDIF
38025
38026 Q2 = Q2inp
38027 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
38028* WRITE(LO,92) Q2
38029 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
38030 Q2 = 0.99E6
38031* STOP
38032 ENDIF
38033
38034*
38035*...INTERPOLATION :
38036 NA(1) = NX
38037 NA(2) = NQ
38038 XT(1) = DLOG(X)
38039 XT(2) = DLOG(Q2)
38040 X1 = 1.- X
38041 XV = X**0.5
38042 XS = X**(-0.2)
38043 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
38044 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
38045 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
38046 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
38047 US = 0.5 * (UD - DE)
38048 DS = 0.5 * (UD + DE)
38049 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
38050 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
38051
38052 END
38053
38054CDECK ID>, PHO_DOR94LO
38055* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38056* *
38057* 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 *
38058* *
38059* 1994 UPDATE *
38060* *
38061* FOR A DETAILED EXPLANATION SEE *
38062* M. GLUECK, E.REYA, A.VOGT : *
38063* DO-TH 94/24 = DESY 94-206 *
38064* (TO APPEAR IN Z. PHYS. C) *
38065* *
38066* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
38067* Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
38068* X BETWEEN 1.E-5 AND 1. *
38069* LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
38070* IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
38071* *
38072* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
38073* M(C) = 1.5, M(B) = 4.5 *
38074* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
38075* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38076* LAMBDA(5) = 0.153, *
38077* NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38078* LAMBDA(5) = 0.131. *
38079* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
38080* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
38081* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
38082* IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
38083* GRV PARAMETRIZATION. *
38084* *
38085* NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
38086* (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
38087* THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
38088* *
38089* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38090*
38091*...INPUT PARAMETERS :
38092*
38093* X = MOMENTUM FRACTION
38094* Q2 = SCALE Q**2 IN GEV**2
38095*
38096*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
38097*
38098* UV = U(VAL) = U - U(BAR)
38099* DV = D(VAL) = D - D(BAR)
38100* DEL = D(BAR) - U(BAR)
38101* UDB = U(BAR) + D(BAR)
38102* SB = S = S(BAR)
38103* GL = GLUON
38104*
38105*...LO PARAMETRIZATION :
38106*
38107 SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38108 IMPLICIT DOUBLE PRECISION (A - Z)
38109 SAVE
38110
38111 MU2 = 0.23
38112 LAM2 = 0.2322 * 0.2322
38113 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38114 DS = SQRT (S)
38115 S2 = S * S
38116 S3 = S2 * S
38117*...UV :
38118 NU = 2.284 + 0.802 * S + 0.055 * S2
38119 AKU = 0.590 - 0.024 * S
38120 BKU = 0.131 + 0.063 * S
38121 AU = -0.449 - 0.138 * S - 0.076 * S2
38122 BU = 0.213 + 2.669 * S - 0.728 * S2
38123 CU = 8.854 - 9.135 * S + 1.979 * S2
38124 DU = 2.997 + 0.753 * S - 0.076 * S2
38125 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38126*...DV :
38127 ND = 0.371 + 0.083 * S + 0.039 * S2
38128 AKD = 0.376
38129 BKD = 0.486 + 0.062 * S
38130 AD = -0.509 + 3.310 * S - 1.248 * S2
38131 BD = 12.41 - 10.52 * S + 2.267 * S2
38132 CD = 6.373 - 6.208 * S + 1.418 * S2
38133 DD = 3.691 + 0.799 * S - 0.071 * S2
38134 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38135*...DEL :
38136 NE = 0.082 + 0.014 * S + 0.008 * S2
38137 AKE = 0.409 - 0.005 * S
38138 BKE = 0.799 + 0.071 * S
38139 AE = -38.07 + 36.13 * S - 0.656 * S2
38140 BE = 90.31 - 74.15 * S + 7.645 * S2
38141 CE = 0.0
38142 DE = 7.486 + 1.217 * S - 0.159 * S2
38143 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38144*...UDB :
38145 ALX = 1.451
38146 BEX = 0.271
38147 AKX = 0.410 - 0.232 * S
38148 BKX = 0.534 - 0.457 * S
38149 AGX = 0.890 - 0.140 * S
38150 BGX = -0.981
38151 CX = 0.320 + 0.683 * S
38152 DX = 4.752 + 1.164 * S + 0.286 * S2
38153 EX = 4.119 + 1.713 * S
38154 ESX = 0.682 + 2.978 * S
38155 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38156*...SB :
38157 ALS = 0.914
38158 BES = 0.577
38159 AKS = 1.798 - 0.596 * S
38160 AS = -5.548 + 3.669 * DS - 0.616 * S
38161 BS = 18.92 - 16.73 * DS + 5.168 * S
38162 DST = 6.379 - 0.350 * S + 0.142 * S2
38163 EST = 3.981 + 1.638 * S
38164 ESS = 6.402
38165 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38166*...GL :
38167 ALG = 0.524
38168 BEG = 1.088
38169 AKG = 1.742 - 0.930 * S
38170 BKG = - 0.399 * S2
38171 AG = 7.486 - 2.185 * S
38172 BG = 16.69 - 22.74 * S + 5.779 * S2
38173 CG = -25.59 + 29.71 * S - 7.296 * S2
38174 DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
38175 EG = 0.807 + 2.005 * S
38176 ESG = 3.841 + 0.316 * S
38177 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38178
38179 END
38180
38181*
38182*...NLO PARAMETRIZATION (MS(BAR)) :
38183*
38184CDECK ID>, PHO_DOR94HO
38185 SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38186 IMPLICIT DOUBLE PRECISION (A - Z)
38187 SAVE
38188
38189 MU2 = 0.34
38190 LAM2 = 0.248 * 0.248
38191 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38192 DS = SQRT (S)
38193 S2 = S * S
38194 S3 = S2 * S
38195*...UV :
38196 NU = 1.304 + 0.863 * S
38197 AKU = 0.558 - 0.020 * S
38198 BKU = 0.183 * S
38199 AU = -0.113 + 0.283 * S - 0.321 * S2
38200 BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38201 CU = 7.771 - 10.09 * S + 2.630 * S2
38202 DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38203 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38204*...DV :
38205 ND = 0.102 - 0.017 * S + 0.005 * S2
38206 AKD = 0.270 - 0.019 * S
38207 BKD = 0.260
38208 AD = 2.393 + 6.228 * S - 0.881 * S2
38209 BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38210 CD = 17.83 - 53.47 * S + 21.24 * S2
38211 DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38212 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38213*...DEL :
38214 NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38215 AKE = 0.409 - 0.007 * S
38216 BKE = 0.782 + 0.082 * S
38217 AE = -29.65 + 26.49 * S + 5.429 * S2
38218 BE = 90.20 - 74.97 * S + 4.526 * S2
38219 CE = 0.0
38220 DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38221 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38222*...UDB :
38223 ALX = 0.877
38224 BEX = 0.561
38225 AKX = 0.275
38226 BKX = 0.0
38227 AGX = 0.997
38228 BGX = 3.210 - 1.866 * S
38229 CX = 7.300
38230 DX = 9.010 + 0.896 * DS + 0.222 * S2
38231 EX = 3.077 + 1.446 * S
38232 ESX = 3.173 - 2.445 * DS + 2.207 * S
38233 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38234*...SB :
38235 ALS = 0.756
38236 BES = 0.216
38237 AKS = 1.690 + 0.650 * DS - 0.922 * S
38238 AS = -4.329 + 1.131 * S
38239 BS = 9.568 - 1.744 * S
38240 DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38241 EST = 3.031 + 1.639 * S
38242 ESS = 5.837 + 0.815 * S
38243 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38244*...GL :
38245 ALG = 1.014
38246 BEG = 1.738
38247 AKG = 1.724 + 0.157 * S
38248 BKG = 0.800 + 1.016 * S
38249 AG = 7.517 - 2.547 * S
38250 BG = 34.09 - 52.21 * DS + 17.47 * S
38251 CG = 4.039 + 1.491 * S
38252 DG = 3.404 + 0.830 * S
38253 EG = -1.112 + 3.438 * S - 0.302 * S2
38254 ESG = 3.256 - 0.436 * S
38255 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38256
38257 END
38258
38259CDECK ID>, PHO_DOR94DI
38260*
38261*...NLO PARAMETRIZATION (DIS) :
38262*
38263 SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38264 IMPLICIT DOUBLE PRECISION (A - Z)
38265 SAVE
38266
38267 MU2 = 0.34
38268 LAM2 = 0.248 * 0.248
38269 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38270 DS = SQRT (S)
38271 S2 = S * S
38272 S3 = S2 * S
38273*...UV :
38274 NU = 2.484 + 0.116 * S + 0.093 * S2
38275 AKU = 0.563 - 0.025 * S
38276 BKU = 0.054 + 0.154 * S
38277 AU = -0.326 - 0.058 * S - 0.135 * S2
38278 BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38279 CU = 11.52 - 12.99 * S + 3.161 * S2
38280 DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38281 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38282*...DV :
38283 ND = 0.156 - 0.017 * S
38284 AKD = 0.299 - 0.022 * S
38285 BKD = 0.259 - 0.015 * S
38286 AD = 3.445 + 1.278 * S + 0.326 * S2
38287 BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38288 CD = 55.45 - 69.92 * S + 20.78 * S2
38289 DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38290 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38291*...DEL :
38292 NE = 0.099 + 0.019 * S + 0.002 * S2
38293 AKE = 0.419 - 0.013 * S
38294 BKE = 1.064 - 0.038 * S
38295 AE = -44.00 + 98.70 * S - 14.79 * S2
38296 BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38297 CE = 84.57 - 108.8 * S + 31.52 * S2
38298 DE = 7.469 + 2.480 * S - 0.866 * S2
38299 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38300*...UDB :
38301 ALX = 1.215
38302 BEX = 0.466
38303 AKX = 0.326 + 0.150 * S
38304 BKX = 0.956 + 0.405 * S
38305 AGX = 0.272
38306 BGX = 3.794 - 2.359 * DS
38307 CX = 2.014
38308 DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38309 EX = 3.049 + 1.597 * S
38310 ESX = 4.396 - 4.594 * DS + 3.268 * S
38311 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38312*...SB :
38313 ALS = 0.175
38314 BES = 0.344
38315 AKS = 1.415 - 0.641 * DS
38316 AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
38317 BS = 5.617 + 5.709 * DS - 3.972 * S
38318 DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
38319 EST = 4.546 + 0.372 * S2
38320 ESS = 5.053 - 1.070 * S + 0.805 * S2
38321 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38322*...GL :
38323 ALG = 1.258
38324 BEG = 1.846
38325 AKG = 2.423
38326 BKG = 2.427 + 1.311 * S - 0.153 * S2
38327 AG = 25.09 - 7.935 * S
38328 BG = -14.84 - 124.3 * DS + 72.18 * S
38329 CG = 590.3 - 173.8 * S
38330 DG = 5.196 + 1.857 * S
38331 EG = -1.648 + 3.988 * S - 0.432 * S2
38332 ESG = 3.232 - 0.542 * S
38333 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38334
38335 END
38336
38337*
38338*...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38339*
38340CDECK ID>, PHO_DOR94FV
38341 DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38342 IMPLICIT DOUBLE PRECISION (A - Z)
38343 SAVE
38344
38345 DX = SQRT (X)
38346 PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38347
38348 END
38349
38350CDECK ID>, PHO_DOR94FW
38351 DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38352 & A,B,C,D,E,ES)
38353 IMPLICIT DOUBLE PRECISION (A - Z)
38354 SAVE
38355
38356 LX = LOG (1./X)
38357 PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38358 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38359
38360 END
38361
38362CDECK ID>, PHO_DOR94FS
38363 DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38364 IMPLICIT DOUBLE PRECISION (A - Z)
38365 SAVE
38366
38367 DX = SQRT (X)
38368 LX = LOG (1./X)
38369 PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38370 1 * DEXP (-E + SQRT (ES * S**BE * LX))
38371
38372 END
38373
38374CDECK ID>, PHO_DOR92LO
38375*
38376*
38377* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38378* *
38379* 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 *
38380* *
38381* FOR A DETAILED EXPLANATION SEE : *
38382* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
38383* *
38384* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38385* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38386* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38387* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38388* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38389* *
38390* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38391* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38392* *
38393* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38394* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38395* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38396* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38397* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38398* *
38399* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38400* *
38401* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38402C
38403 SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38404 IMPLICIT DOUBLE PRECISION (A - Z)
38405 SAVE
38406
38407 MU2 = 0.25
38408 LAM2 = 0.232 * 0.232
38409 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38410 S2 = S * S
38411 S3 = S2 * S
38412C...X * (UV + DV) :
38413 NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38414 AKUD = 0.326
38415 AGUD = -1.97 + 6.74 * S - 1.96 * S2
38416 BUD = 24.4 - 20.7 * S + 4.08 * S2
38417 DUD = 2.86 + 0.70 * S - 0.02 * S2
38418 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38419C...X * DV :
38420 ND = 0.579 + 0.283 * S + 0.047 * S2
38421 AKD = 0.523 - 0.015 * S
38422 AGD = 2.22 - 0.59 * S - 0.27 * S2
38423 BD = 5.95 - 6.19 * S + 1.55 * S2
38424 DD = 3.57 + 0.94 * S - 0.16 * S2
38425 DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38426C...X * G :
38427 ALG = 0.558
38428 BEG = 1.218
38429 AKG = 1.00 - 0.17 * S
38430 BKG = 0.0
38431 AGG = 0.0 + 4.879 * S - 1.383 * S2
38432 BGG = 25.92 - 28.97 * S + 5.596 * S2
38433 CG = -25.69 + 23.68 * S - 1.975 * S2
38434 DG = 2.537 + 1.718 * S + 0.353 * S2
38435 EG = 0.595 + 2.138 * S
38436 ESG = 4.066
38437 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38438C...X * UBAR = X * DBAR :
38439 ALU = 1.396
38440 BEU = 1.331
38441 AKU = 0.412 - 0.171 * S
38442 BKU = 0.566 - 0.496 * S
38443 AGU = 0.363
38444 BGU = -1.196
38445 CU = 1.029 + 1.785 * S - 0.459 * S2
38446 DU = 4.696 + 2.109 * S
38447 EU = 3.838 + 1.944 * S
38448 ESU = 2.845
38449 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38450C...X * SBAR = X * S :
38451 SS = 0.0
38452 ALS = 0.803
38453 BES = 0.563
38454 AKS = 2.082 - 0.577 * S
38455 AGS = -3.055 + 1.024 * S ** 0.67
38456 BS = 27.4 - 20.0 * S ** 0.154
38457 DS = 6.22
38458 EST = 4.33 + 1.408 * S
38459 ESS = 8.27 - 0.437 * S
38460 SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38461C...X * CBAR = X * C :
38462 SC = 0.888
38463 ALC = 1.01
38464 BEC = 0.37
38465 AKC = 0.0
38466 AGC = 0.0
38467 BC = 4.24 - 0.804 * S
38468 DC = 3.46 + 1.076 * S
38469 EC = 4.61 + 1.490 * S
38470 ESC = 2.555 + 1.961 * S
38471 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38472C...X * BBAR = X * B :
38473 SBO = 1.351
38474 ALB = 1.00
38475 BEB = 0.51
38476 AKB = 0.0
38477 AGB = 0.0
38478 BBO = 1.848
38479 DB = 2.929 + 1.396 * S
38480 EB = 4.71 + 1.514 * S
38481 ESB = 4.02 + 1.239 * S
38482 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38483
38484 END
38485
38486CDECK ID>, PHO_DOR92HO
38487 SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38488 IMPLICIT DOUBLE PRECISION (A - Z)
38489 SAVE
38490
38491 MU2 = 0.3
38492 LAM2 = 0.248 * 0.248
38493 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38494 DS = SQRT (S)
38495 S2 = S * S
38496 S3 = S2 * S
38497C...X * (UV + DV) :
38498 NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38499 AKUD = 0.285
38500 AGUD = -2.28 + 15.73 * S - 4.58 * S2
38501 BUD = 56.7 - 53.6 * S + 11.21 * S2
38502 DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
38503 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38504C...X * DV :
38505 ND = 0.459 + 0.315 * DS + 0.515 * S
38506 AKD = 0.624 - 0.031 * S
38507 AGD = 8.13 - 6.77 * DS + 0.46 * S
38508 BD = 6.59 - 12.83 * DS + 5.65 * S
38509 DD = 3.98 + 1.04 * S - 0.34 * S2
38510 DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38511C...X * G :
38512 ALG = 1.128
38513 BEG = 1.575
38514 AKG = 0.323 + 1.653 * S
38515 BKG = 0.811 + 2.044 * S
38516 AGG = 0.0 + 1.963 * S - 0.519 * S2
38517 BGG = 0.078 + 6.24 * S
38518 CG = 30.77 - 24.19 * S
38519 DG = 3.188 + 0.720 * S
38520 EG = -0.881 + 2.687 * S
38521 ESG = 2.466
38522 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38523C...X * UBAR = X * DBAR :
38524 ALU = 0.594
38525 BEU = 0.614
38526 AKU = 0.636 - 0.084 * S
38527 BKU = 0.0
38528 AGU = 1.121 - 0.193 * S
38529 BGU = 0.751 - 0.785 * S
38530 CU = 8.57 - 1.763 * S
38531 DU = 10.22 + 0.668 * S
38532 EU = 3.784 + 1.280 * S
38533 ESU = 1.808 + 0.980 * S
38534 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38535C...X * SBAR = X * S :
38536 SS = 0.0
38537 ALS = 0.756
38538 BES = 0.101
38539 AKS = 2.942 - 1.016 * S
38540 AGS = -4.60 + 1.167 * S
38541 BS = 9.31 - 1.324 * S
38542 DS = 11.49 - 1.198 * S + 0.053 * S2
38543 EST = 2.630 + 1.729 * S
38544 ESS = 8.12
38545 SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38546C...X * CBAR = X * C :
38547 SC = 0.820
38548 ALC = 0.98
38549 BEC = 0.0
38550 AKC = -0.625 - 0.523 * S
38551 AGC = 0.0
38552 BC = 1.896 + 1.616 * S
38553 DC = 4.12 + 0.683 * S
38554 EC = 4.36 + 1.328 * S
38555 ESC = 0.677 + 0.679 * S
38556 CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38557C...X * BBAR = X * B :
38558 SBO = 1.297
38559 ALB = 0.99
38560 BEB = 0.0
38561 AKB = 0.0 - 0.193 * S
38562 AGB = 0.0
38563 BBO = 0.0
38564 DB = 3.447 + 0.927 * S
38565 EB = 4.68 + 1.259 * S
38566 ESB = 1.892 + 2.199 * S
38567 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38568
38569 END
38570
38571CDECK ID>, PHO_DOR92FV
38572 DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38573 IMPLICIT DOUBLE PRECISION (A - Z)
38574 SAVE
38575 DX = SQRT (X)
38576 PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38577
38578 END
38579
38580CDECK ID>, PHO_DOR92FW
38581 DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38582 & AL,BE,AK,BK,AG,BG,C,D,E,ES)
38583 IMPLICIT DOUBLE PRECISION (A - Z)
38584 SAVE
38585 LX = LOG (1./X)
38586 PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38587 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38588
38589 END
38590
38591CDECK ID>, PHO_DOR92FS
38592 DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38593 IMPLICIT DOUBLE PRECISION (A - Z)
38594 SAVE
38595
38596 DX = SQRT (X)
38597 LX = LOG (1./X)
38598 IF (S .LE. ST) THEN
38599 PHO_DOR92FS = 0.D0
38600 ELSE
38601 PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38602 1 * EXP (-E + SQRT (ES * S**BE * LX))
38603 END IF
38604
38605 END
38606
38607CDECK ID>, PHO_DORPLO
38608*
38609* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38610* *
38611* G R V - P I O N - P A R A M E T R I Z A T I O N S *
38612* *
38613* FOR A DETAILED EXPLANATION SEE : *
38614* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
38615* *
38616* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38617* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38618* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38619* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38620* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38621* *
38622* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38623* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38624* *
38625* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38626* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38627* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38628* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38629* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38630* *
38631* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38632* *
38633* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38634C
38635 SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38636 IMPLICIT DOUBLE PRECISION (A - Z)
38637 SAVE
38638
38639 MU2 = 0.25
38640 LAM2 = 0.232 * 0.232
38641 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38642 DS = SQRT (S)
38643 S2 = S * S
38644C...X * VALENCE :
38645 NV = 0.519 + 0.180 * S - 0.011 * S2
38646 AKV = 0.499 - 0.027 * S
38647 AGV = 0.381 - 0.419 * S
38648 DV = 0.367 + 0.563 * S
38649 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38650C...X * GLUON :
38651 ALG = 0.599
38652 BEG = 1.263
38653 AKG = 0.482 + 0.341 * DS
38654 BKG = 0.0
38655 AGG = 0.678 + 0.877 * S - 0.175 * S2
38656 BGG = 0.338 - 1.597 * S
38657 CG = 0.0 - 0.233 * S + 0.406 * S2
38658 DG = 0.390 + 1.053 * S
38659 EG = 0.618 + 2.070 * S
38660 ESG = 3.676
38661 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38662C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38663 SL = 0.0
38664 ALS = 0.55
38665 BES = 0.56
38666 AKS = 2.538 - 0.763 * S
38667 AGS = -0.748
38668 BS = 0.313 + 0.935 * S
38669 DS = 3.359
38670 EST = 4.433 + 1.301 * S
38671 ESS = 9.30 - 0.887 * S
38672 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38673C...X * CBAR = X * C :
38674 SC = 0.888
38675 ALC = 1.02
38676 BEC = 0.39
38677 AKC = 0.0
38678 AGC = 0.0
38679 BC = 1.008
38680 DC = 1.208 + 0.771 * S
38681 EC = 4.40 + 1.493 * S
38682 ESC = 2.032 + 1.901 * S
38683 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38684C...X * BBAR = X * B :
38685 SBO = 1.351
38686 ALB = 1.03
38687 BEB = 0.39
38688 AKB = 0.0
38689 AGB = 0.0
38690 BBO = 0.0
38691 DB = 0.697 + 0.855 * S
38692 EB = 4.51 + 1.490 * S
38693 ESB = 3.056 + 1.694 * S
38694 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38695
38696 END
38697
38698CDECK ID>, PHO_DORPHO
38699 SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38700 IMPLICIT DOUBLE PRECISION (A - Z)
38701 SAVE
38702
38703 MU2 = 0.3
38704 LAM2 = 0.248 * 0.248
38705 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38706 DS = SQRT (S)
38707 S2 = S * S
38708C...X * VALENCE :
38709 NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
38710 AKV = 0.505 - 0.033 * S
38711 AGV = 0.748 - 0.669 * DS - 0.133 * S
38712 DV = 0.365 + 0.197 * DS + 0.394 * S
38713 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38714C...X * GLUON :
38715 ALG = 1.096
38716 BEG = 1.371
38717 AKG = 0.437 - 0.689 * DS
38718 BKG = -0.631
38719 AGG = 1.324 - 0.441 * DS - 0.130 * S
38720 BGG = -0.955 + 0.259 * S
38721 CG = 1.075 - 0.302 * S
38722 DG = 1.158 + 1.229 * S
38723 EG = 0.0 + 2.510 * S
38724 ESG = 2.604 + 0.165 * S
38725 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38726C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38727 SL = 0.0
38728 ALS = 0.85
38729 BES = 0.96
38730 AKS = -0.350 + 0.806 * S
38731 AGS = -1.663
38732 BS = 3.148
38733 DS = 2.273 + 1.438 * S
38734 EST = 3.214 + 1.545 * S
38735 ESS = 1.341 + 1.938 * S
38736 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38737C...X * CBAR = X * C :
38738 SC = 0.820
38739 ALC = 0.98
38740 BEC = 0.0
38741 AKC = 0.0 - 0.457 * S
38742 AGC = 0.0
38743 BC = -1.00 + 1.40 * S
38744 DC = 1.318 + 0.584 * S
38745 EC = 4.45 + 1.235 * S
38746 ESC = 1.496 + 1.010 * S
38747 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38748C...X * BBAR = X * B :
38749 SBO = 1.297
38750 ALB = 0.99
38751 BEB = 0.0
38752 AKB = 0.0 - 0.172 * S
38753 AGB = 0.0
38754 BBO = 0.0
38755 DB = 1.447 + 0.485 * S
38756 EB = 4.79 + 1.164 * S
38757 ESB = 1.724 + 2.121 * S
38758 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38759
38760 END
38761
38762CDECK ID>, PHO_DORFVP
38763 DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
38764 IMPLICIT DOUBLE PRECISION (A - Z)
38765 SAVE
38766
38767 DX = SQRT (X)
38768 PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
38769
38770 END
38771
38772CDECK ID>, PHO_DORFGP
38773 DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
38774 & BG,C,D,E,ES)
38775 IMPLICIT DOUBLE PRECISION (A - Z)
38776 SAVE
38777
38778 DX = SQRT (X)
38779 LX = LOG (1./X)
38780 PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
38781 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38782
38783 END
38784
38785CDECK ID>, PHO_DORFQP
38786 DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38787 IMPLICIT DOUBLE PRECISION (A - Z)
38788 SAVE
38789
38790 DX = SQRT (X)
38791 LX = LOG (1./X)
38792 IF (S .LE. ST) THEN
38793 PHO_DORFQP = 0.0
38794 ELSE
38795 PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38796 1 * EXP (-E + SQRT (ES * S**BE * LX))
38797 END IF
38798
38799 END
38800
38801CDECK ID>, PHO_DORGLO
38802* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38803* *
38804* 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 *
38805* *
38806* FOR A DETAILED EXPLANATION SEE : *
38807* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
38808* *
38809* THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
38810* *
38811* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38812* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38813* / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38814* *
38815* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38816* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38817* *
38818* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38819* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38820* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38821* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38822* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38823* *
38824* HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
38825* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
38826* *
38827* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38828C
38829 SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
38830 IMPLICIT DOUBLE PRECISION (A - Z)
38831 SAVE
38832
38833 MU2 = 0.25
38834 LAM2 = 0.232 * 0.232
38835 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38836 SS = SQRT (S)
38837 S2 = S * S
38838C...X * U = X * UBAR :
38839 AL = 1.717
38840 BE = 0.641
38841 AK = 0.500 - 0.176 * S
38842 BK = 15.00 - 5.687 * SS - 0.552 * S2
38843 AG = 0.235 + 0.046 * SS
38844 BG = 0.082 - 0.051 * S + 0.168 * S2
38845 C = 0.0 + 0.459 * S
38846 D = 0.354 - 0.061 * S
38847 E = 4.899 + 1.678 * S
38848 ES = 2.046 + 1.389 * S
38849 UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38850C...X * D = X * DBAR :
38851 AL = 1.549
38852 BE = 0.782
38853 AK = 0.496 + 0.026 * S
38854 BK = 0.685 - 0.580 * SS + 0.608 * S2
38855 AG = 0.233 + 0.302 * S
38856 BG = 0.0 - 0.818 * S + 0.198 * S2
38857 C = 0.114 + 0.154 * S
38858 D = 0.405 - 0.195 * S + 0.046 * S2
38859 E = 4.807 + 1.226 * S
38860 ES = 2.166 + 0.664 * S
38861 DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38862C...X * G :
38863 AL = 0.676
38864 BE = 1.089
38865 AK = 0.462 - 0.524 * SS
38866 BK = 5.451 - 0.804 * S2
38867 AG = 0.535 - 0.504 * SS + 0.288 * S2
38868 BG = 0.364 - 0.520 * S
38869 C = -0.323 + 0.115 * S2
38870 D = 0.233 + 0.790 * S - 0.139 * S2
38871 E = 0.893 + 1.968 * S
38872 ES = 3.432 + 0.392 * S
38873 GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38874C...X * S = X * SBAR :
38875 SF = 0.0
38876 AL = 1.609
38877 BE = 0.962
38878 AK = 0.470 - 0.099 * S2
38879 BK = 3.246
38880 AG = 0.121 - 0.068 * SS
38881 BG = -0.090 + 0.074 * S
38882 C = 0.062 + 0.034 * S
38883 D = 0.0 + 0.226 * S - 0.060 * S2
38884 E = 4.288 + 1.707 * S
38885 ES = 2.122 + 0.656 * S
38886 SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38887C...X * C = X * CBAR :
38888 SF = 0.888
38889 AL = 0.970
38890 BE = 0.545
38891 AK = 1.254 - 0.251 * S
38892 BK = 3.932 - 0.327 * S2
38893 AG = 0.658 + 0.202 * S
38894 BG = -0.699
38895 C = 0.965
38896 D = 0.0 + 0.141 * S - 0.027 * S2
38897 E = 4.911 + 0.969 * S
38898 ES = 2.796 + 0.952 * S
38899 CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38900C...X * B = X * BBAR :
38901 SF = 1.351
38902 AL = 1.016
38903 BE = 0.338
38904 AK = 1.961 - 0.370 * S
38905 BK = 0.923 + 0.119 * S
38906 AG = 0.815 + 0.207 * S
38907 BG = -2.275
38908 C = 1.480
38909 D = -0.223 + 0.173 * S
38910 E = 5.426 + 0.623 * S
38911 ES = 3.819 + 0.901 * S
38912 BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38913
38914 END
38915
38916CDECK ID>, PHO_DORGHO
38917 SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
38918 IMPLICIT DOUBLE PRECISION (A - Z)
38919 SAVE
38920
38921 MU2 = 0.3
38922 LAM2 = 0.248 * 0.248
38923 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38924 SS = SQRT (S)
38925 S2 = S * S
38926C...X * U = X * UBAR :
38927 AL = 0.583
38928 BE = 0.688
38929 AK = 0.449 - 0.025 * S - 0.071 * S2
38930 BK = 5.060 - 1.116 * SS
38931 AG = 0.103
38932 BG = 0.319 + 0.422 * S
38933 C = 1.508 + 4.792 * S - 1.963 * S2
38934 D = 1.075 + 0.222 * SS - 0.193 * S2
38935 E = 4.147 + 1.131 * S
38936 ES = 1.661 + 0.874 * S
38937 UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38938C...X * D = X * DBAR :
38939 AL = 0.591
38940 BE = 0.698
38941 AK = 0.442 - 0.132 * S - 0.058 * S2
38942 BK = 5.437 - 1.916 * SS
38943 AG = 0.099
38944 BG = 0.311 - 0.059 * S
38945 C = 0.800 + 0.078 * S - 0.100 * S2
38946 D = 0.862 + 0.294 * SS - 0.184 * S2
38947 E = 4.202 + 1.352 * S
38948 ES = 1.841 + 0.990 * S
38949 DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38950C...X * G :
38951 AL = 1.161
38952 BE = 1.591
38953 AK = 0.530 - 0.742 * SS + 0.025 * S2
38954 BK = 5.662
38955 AG = 0.533 - 0.281 * SS + 0.218 * S2
38956 BG = 0.025 - 0.518 * S + 0.156 * S2
38957 C = -0.282 + 0.209 * S2
38958 D = 0.107 + 1.058 * S - 0.218 * S2
38959 E = 0.0 + 2.704 * S
38960 ES = 3.071 - 0.378 * S
38961 GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38962C...X * S = X * SBAR :
38963 SF = 0.0
38964 AL = 0.635
38965 BE = 0.456
38966 AK = 1.770 - 0.735 * SS - 0.079 * S2
38967 BK = 3.832
38968 AG = 0.084 - 0.023 * S
38969 BG = 0.136
38970 C = 2.119 - 0.942 * S + 0.063 * S2
38971 D = 1.271 + 0.076 * S - 0.190 * S2
38972 E = 4.604 + 0.737 * S
38973 ES = 1.641 + 0.976 * S
38974 SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38975C...X * C = X * CBAR :
38976 SF = 0.820
38977 AL = 0.926
38978 BE = 0.152
38979 AK = 1.142 - 0.175 * S
38980 BK = 3.276
38981 AG = 0.504 + 0.317 * S
38982 BG = -0.433
38983 C = 3.334
38984 D = 0.398 + 0.326 * S - 0.107 * S2
38985 E = 5.493 + 0.408 * S
38986 ES = 2.426 + 1.277 * S
38987 CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38988C...X * B = X * BBAR :
38989 SF = 1.297
38990 AL = 0.969
38991 BE = 0.266
38992 AK = 1.953 - 0.391 * S
38993 BK = 1.657 - 0.161 * S
38994 AG = 1.076 + 0.034 * S
38995 BG = -2.015
38996 C = 1.662
38997 D = 0.353 + 0.016 * S
38998 E = 5.713 + 0.249 * S
38999 ES = 3.456 + 0.673 * S
39000 BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39001
39002 END
39003
39004CDECK ID>, PHO_DORGH0
39005 SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
39006 IMPLICIT DOUBLE PRECISION (A - Z)
39007 SAVE
39008
39009 MU2 = 0.3
39010 LAM2 = 0.248 * 0.248
39011 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39012 SS = SQRT (S)
39013 S2 = S * S
39014C...X * U = X * UBAR :
39015 AL = 1.447
39016 BE = 0.848
39017 AK = 0.527 + 0.200 * S - 0.107 * S2
39018 BK = 7.106 - 0.310 * SS - 0.786 * S2
39019 AG = 0.197 + 0.533 * S
39020 BG = 0.062 - 0.398 * S + 0.109 * S2
39021 C = 0.755 * S - 0.112 * S2
39022 D = 0.318 - 0.059 * S
39023 E = 4.225 + 1.708 * S
39024 ES = 1.752 + 0.866 * S
39025 U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39026C...X * D = X * DBAR :
39027 AL = 1.424
39028 BE = 0.770
39029 AK = 0.500 + 0.067 * SS - 0.055 * S2
39030 BK = 0.376 - 0.453 * SS + 0.405 * S2
39031 AG = 0.156 + 0.184 * S
39032 BG = 0.0 - 0.528 * S + 0.146 * S2
39033 C = 0.121 + 0.092 * S
39034 D = 0.379 - 0.301 * S + 0.081 * S2
39035 E = 4.346 + 1.638 * S
39036 ES = 1.645 + 1.016 * S
39037 D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39038C...X * G :
39039 AL = 0.661
39040 BE = 0.793
39041 AK = 0.537 - 0.600 * SS
39042 BK = 6.389 - 0.953 * S2
39043 AG = 0.558 - 0.383 * SS + 0.261 * S2
39044 BG = 0.0 - 0.305 * S
39045 C = -0.222 + 0.078 * S2
39046 D = 0.153 + 0.978 * S - 0.209 * S2
39047 E = 1.429 + 1.772 * S
39048 ES = 3.331 + 0.806 * S
39049 G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39050C...X * S = X * SBAR :
39051 SF = 0.0
39052 AL = 1.578
39053 BE = 0.863
39054 AK = 0.622 + 0.332 * S - 0.300 * S2
39055 BK = 2.469
39056 AG = 0.211 - 0.064 * SS - 0.018 * S2
39057 BG = -0.215 + 0.122 * S
39058 C = 0.153
39059 D = 0.0 + 0.253 * S - 0.081 * S2
39060 E = 3.990 + 2.014 * S
39061 ES = 1.720 + 0.986 * S
39062 S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39063C...X * C = X * CBAR :
39064 SF = 0.820
39065 AL = 0.929
39066 BE = 0.381
39067 AK = 1.228 - 0.231 * S
39068 BK = 3.806 - 0.337 * S2
39069 AG = 0.932 + 0.150 * S
39070 BG = -0.906
39071 C = 1.133
39072 D = 0.0 + 0.138 * S - 0.028 * S2
39073 E = 5.588 + 0.628 * S
39074 ES = 2.665 + 1.054 * S
39075 C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39076C...X * B = X * BBAR :
39077 SF = 1.297
39078 AL = 0.970
39079 BE = 0.207
39080 AK = 1.719 - 0.292 * S
39081 BK = 0.928 + 0.096 * S
39082 AG = 0.845 + 0.178 * S
39083 BG = -2.310
39084 C = 1.558
39085 D = -0.191 + 0.151 * S
39086 E = 6.089 + 0.282 * S
39087 ES = 3.379 + 1.062 * S
39088 B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39089
39090 END
39091
39092CDECK ID>, PHO_DORGF
39093 DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39094 & AG,BG,C,D,E,ES)
39095 IMPLICIT DOUBLE PRECISION (A - Z)
39096 SAVE
39097
39098 SX = SQRT (X)
39099 LX = LOG (1./X)
39100 PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
39101 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39102
39103 END
39104
39105CDECK ID>, PHO_DORGFS
39106 DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39107 & C,D,E,ES)
39108 IMPLICIT DOUBLE PRECISION (A - Z)
39109 SAVE
39110
39111 IF (S .LE. SF) THEN
39112 PHO_DORGFS = 0.0
39113 ELSE
39114 SX = SQRT (X)
39115 LX = LOG (1./X)
39116 DS = S - SF
39117 PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39118 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39119 END IF
39120
39121 END
39122
39123CDECK ID>, PHO_DORGLV
39124* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39125* *
39126* G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
39127* *
39128* FOR A DETAILED EXPLANATION SEE *
39129* M. GLUECK, E.REYA, M. STRATMANN : *
39130* PHYS. REV. D51 (1995) 3220 *
39131* *
39132* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
39133* Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
39134* AND (!) Q**2 > 5 P**2 *
39135* P**2 / GEV**2 BETWEEN 0.0 AND 10. *
39136* P**2 = 0 <=> REAL PHOTON *
39137* X BETWEEN 1.E-4 AND 1. *
39138* *
39139* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
39140* M(C) = 1.5, M(B) = 4.5 *
39141* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
39142* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
39143* LAMBDA(5) = 0.153, *
39144* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
39145* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
39146* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
39147* *
39148* PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
39149* Marco.Stratmann@durham.ac.uk *
39150* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39151*
39152*...INPUT PARAMETERS :
39153*
39154* X = MOMENTUM FRACTION
39155* Q2 = SCALE Q**2 IN GEV**2
39156* P2 = VIRTUALITY OF THE PHOTON IN GEV**2
39157*
39158*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39159*
39160********************************************************
39161* subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39162 subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39163 implicit double precision (a-z)
39164 save
39165
39166C input/output channels
39167 INTEGER LI,LO
39168 COMMON /POINOU/ LI,LO
39169
39170 integer check
39171c
39172c check limits :
39173c
39174 check=0
39175 if(x.lt.0.0001d0) check=1
39176 if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
39177 if(q2.lt.5.d0*p2) check=1
39178c
39179c calculate distributions
39180c
39181 if(check.eq.0) then
39182 call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39183 else
39184 WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39185 WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39186 endif
39187
39188 end
39189
39190CDECK ID>, PHO_grscalc
39191 subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39192 implicit double precision (a-z)
39193 save
39194
39195 dimension u1(40),ds1(40),g1(40)
39196 dimension ud2(20),s2(20),g2(20)
39197 dimension up0(20),dsp0(20),gp0(20)
39198 save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
39199c
39200 data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39201 & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39202 & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39203 & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39204 & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39205 & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39206 & 0.622d0,0.227d0,-0.184d0/
39207 data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39208 & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39209 & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39210 & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39211 & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39212 & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39213 & 0.245d0,-0.171d0/
39214 data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39215 & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39216 & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39217 & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39218 & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39219 & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39220 data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39221 & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39222 & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39223 & -0.614d0,3.548d0/
39224 data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39225 & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39226 & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39227 & -0.48d0,3.401d0/
39228 data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39229 & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39230 & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39231 & -0.079d0/
39232 data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39233 & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39234 & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39235 & 2.294d0/
39236 data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39237 & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39238 & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39239 & 0.814d0,1.531d0,0.124d0/
39240 data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39241 & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39242 & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39243 & 2.264d0,0.2675d0/
39244c
39245 mu2=0.25d0
39246 lam2=0.232d0*0.232d0
39247c
39248 if(p2.le.0.25d0) then
39249 s=log(log(q2/lam2)/log(mu2/lam2))
39250 lp1=0.d0
39251 lp2=0.d0
39252 else
39253 s=log(log(q2/lam2)/log(p2/lam2))
39254 lp1=log(p2/mu2)*log(p2/mu2)
39255 lp2=log(p2/mu2+log(p2/mu2))
39256 endif
39257c
39258 alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39259 bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39260 a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39261 & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39262 b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39263 & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39264 & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39265 gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39266 & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39267 & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39268 ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39269 & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39270 gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39271 & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39272 gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39273 & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39274 ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39275 & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39276 gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39277 & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39278 upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39279c
39280 alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39281 bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39282 a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39283 & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39284 b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39285 & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39286 & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39287 gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39288 & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39289 & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39290 ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39291 & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39292 gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39293 & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39294 gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39295 & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39296 ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39297 & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39298 gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39299 & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39300 dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39301c
39302 alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39303 bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39304 a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39305 & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39306 b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39307 & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39308 gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39309 & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39310 ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39311 & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39312 & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39313 gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39314 & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39315 gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39316 & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39317 & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39318 ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39319 & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39320 gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39321 & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39322 gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39323c
39324 s=log(log(q2/lam2)/log(mu2/lam2))
39325 suppr=1.d0/(1.d0+p2/0.59d0)**2
39326c
39327 alp=ud2(1)
39328 bet=ud2(2)
39329 a=ud2(3)+ud2(4)*s
39330 ga=ud2(5)+ud2(6)*s**0.5
39331 gc=ud2(7)+ud2(8)*s
39332 b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39333 gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39334 gd=ud2(15)+ud2(16)*s
39335 ge=ud2(17)+ud2(18)*s
39336 gep=ud2(19)+ud2(20)*s
39337 udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39338c
39339 alp=s2(1)
39340 bet=s2(2)
39341 a=s2(3)+s2(4)*s
39342 ga=s2(5)+s2(6)*s**0.5
39343 gc=s2(7)+s2(8)*s
39344 b=s2(9)+s2(10)*s+s2(11)*s**2
39345 gb=s2(12)+s2(13)*s+s2(14)*s**2
39346 gd=s2(15)+s2(16)*s
39347 ge=s2(17)+s2(18)*s
39348 gep=s2(19)+s2(20)*s
39349 spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39350c
39351 alp=g2(1)
39352 bet=g2(2)
39353 a=g2(3)+g2(4)*s**0.5
39354 b=g2(5)+g2(6)*s**2
39355 gb=g2(7)+g2(8)*s
39356 ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39357 gc=g2(12)+g2(13)*s**2
39358 gd=g2(14)+g2(15)*s+g2(16)*s**2
39359 ge=g2(17)+g2(18)*s
39360 gep=g2(19)+g2(20)*s
39361 gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39362c
39363 ugam=upart1+udpart2
39364 dgam=dspart1+udpart2
39365 sgam=dspart1+spart2
39366 ggam=gpart1+gpart2
39367c
39368 end
39369
39370CDECK ID>, PHO_grsf1
39371 DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39372 & ge,gep)
39373 implicit double precision (a-z)
39374 save
39375
39376 PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39377 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39378 & (1.d0-x)**gd
39379
39380 end
39381
39382CDECK ID>, PHO_grsf2
39383 DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39384 & ge,gep)
39385 implicit double precision (a-z)
39386 save
39387
39388 PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39389 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39390 & (1.d0-x)**gd
39391
39392 end
39393
39394CDECK ID>, PHO_CKMTPA
39395 SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39396C**********************************************************************
39397C
39398C PDF based on Regge theory, evolved with .... by ....
39399C
39400C input: IPAR 2212 proton (not installed)
39401C 990 Pomeron
39402C
39403C output: parameters of parametrization
39404C
39405C**********************************************************************
39406 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39407 SAVE
39408
39409 CHARACTER*8 PDFNA
39410
39411C input/output channels
39412 INTEGER LI,LO
39413 COMMON /POINOU/ LI,LO
39414
39415 REAL PROP(40),POMP(40)
39416 DATA PROP /
39417 & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39418 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39419 & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
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, .000000E+00, .000000E+00, .000000E+00,
39424 & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39425 DATA POMP /
39426 & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39427 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39428 & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
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, .000000E+00, .000000E+00, .000000E+00,
39433 & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39434
39435 IF(IPA.EQ.2212) THEN
39436 ALA =PROP(1)
39437 Q2MI = PROP(39)
39438 Q2MA = PROP(40)
39439 PDFNA = 'CKMT-PRO'
39440 ELSE IF(IPA.EQ.990) THEN
39441 ALA = POMP(1)
39442 Q2MI = POMP(39)
39443 Q2MA = POMP(40)
39444 PDFNA = 'CKMT-POM'
39445 ELSE
39446 WRITE(LO,'(1X,A,I7)')
39447 & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
39448 STOP
39449 ENDIF
39450 XMI = 1.D-4
39451 XMA = 1.D0
39452 END
39453
39454CDECK ID>, PHO_CKMTPD
39455 SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39456C**********************************************************************
39457C
39458C PDF based on Regge theory, evolved with .... by ....
39459C
39460C input: IPAR 2212 proton (not installed)
39461C 990 Pomeron
39462C
39463C output: PD(-6:6) x*f(x) parton distribution functions
39464C (PDFLIB convention: d = PD(1), u = PD(2) )
39465C
39466C**********************************************************************
39467 SAVE
39468
39469C input/output channels
39470 INTEGER LI,LO
39471 COMMON /POINOU/ LI,LO
39472
39473 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
39474 DIMENSION QQ(7)
39475
39476 Q2=SNGL(SCALE2)
39477 Q1S=Q2
39478 XX=SNGL(X)
39479C QCD lambda for evolution
39480 OWLAM = 0.23D0
39481 OWLAM2=OWLAM**2
39482C Q0**2 for evolution
39483 Q02 = 2.D0
39484C
39485C
39486C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39487C q(6)=x*charm, q(7)=x*gluon
39488C
39489 SB=0.
39490 IF(Q2-Q02) 1,1,2
39491 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39492 1 CONTINUE
39493 IF(IPAR.EQ.2212) THEN
39494* CALL PHO_CKMTPR(XX,SB,QQ
39495 WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39496 CALL PHO_ABORT
39497 ELSE
39498 CALL PHO_CKMTPO(XX,SB,QQ)
39499 ENDIF
39500C
39501 PD(-6) = 0.D0
39502 PD(-5) = 0.D0
39503 PD(-4) = DBLE(QQ(6))
39504 PD(-3) = DBLE(QQ(3))
39505 PD(-2) = DBLE(QQ(4))
39506 PD(-1) = DBLE(QQ(5))
39507 PD(0) = DBLE(QQ(7))
39508 PD(1) = DBLE(QQ(2))
39509 PD(2) = DBLE(QQ(1))
39510 PD(3) = DBLE(QQ(3))
39511 PD(4) = DBLE(QQ(6))
39512 PD(5) = 0.D0
39513 PD(6) = 0.D0
39514 IF(IPAR.EQ.990) THEN
39515 CDN = (PD(1)-PD(-1))/2.D0
39516 CUP = (PD(2)-PD(-2))/2.D0
39517 PD(-1) = PD(-1) + CDN
39518 PD(-2) = PD(-2) + CUP
39519 PD(1) = PD(-1)
39520 PD(2) = PD(-2)
39521 ENDIF
39522 END
39523
39524CDECK ID>, PHO_CKMTPO
39525 SUBROUTINE PHO_CKMTPO(X,S,QQ)
39526C**********************************************************************
39527C
39528C calculation partons in Pomeron
39529C
39530C**********************************************************************
39531 SAVE
39532
39533 DIMENSION QQ(7)
39534
39535C input/output channels
39536 INTEGER LI,LO
39537 COMMON /POINOU/ LI,LO
39538
39539 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39540 EQUIVALENCE (GF(1,1,1),DL(1))
39541 DATA DELTA/.10/
39542
39543C RNG= -.5
39544C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
39545C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
39546 DATA (DL(K),K= 1, 85) /
39547 & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39548 & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39549 & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39550 & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39551 & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39552 & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39553 & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39554 & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39555 & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39556 & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39557 & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39558 & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39559 & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39560 & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39561 & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39562 & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39563 & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39564 DATA (DL(K),K= 86, 170) /
39565 & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39566 & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39567 & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39568 & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39569 & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39570 & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39571 & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39572 & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39573 & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39574 & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39575 & .403294E+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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39580 & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39581 & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39582 DATA (DL(K),K= 171, 255) /
39583 & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39584 & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39585 & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39586 & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39587 & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39588 & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39589 & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39590 & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39591 & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39592 & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39593 & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39594 & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39595 & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39596 & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39597 & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39598 & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39599 & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39600 DATA (DL(K),K= 256, 340) /
39601 & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39602 & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39603 & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39604 & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39605 & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
39606 & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
39607 & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
39608 & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
39609 & .285608E+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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39614 & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
39615 & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
39616 & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
39617 & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
39618 DATA (DL(K),K= 341, 425) /
39619 & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
39620 & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
39621 & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
39622 & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
39623 & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
39624 & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
39625 & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
39626 & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
39627 & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
39628 & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
39629 & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
39630 & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
39631 & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
39632 & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
39633 & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
39634 & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
39635 & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
39636 DATA (DL(K),K= 426, 510) /
39637 & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
39638 & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
39639 & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
39640 & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
39641 & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
39642 & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
39643 & .198603E+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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39648 & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
39649 & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
39650 & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
39651 & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
39652 & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
39653 & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
39654 DATA (DL(K),K= 511, 595) /
39655 & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
39656 & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
39657 & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
39658 & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
39659 & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
39660 & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
39661 & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
39662 & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
39663 & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
39664 & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
39665 & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
39666 & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
39667 & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
39668 & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
39669 & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
39670 & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
39671 & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
39672 DATA (DL(K),K= 596, 680) /
39673 & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
39674 & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
39675 & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
39676 & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
39677 & .135299E+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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39682 & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
39683 & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
39684 & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
39685 & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
39686 & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
39687 & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
39688 & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
39689 & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
39690 DATA (DL(K),K= 681, 765) /
39691 & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
39692 & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
39693 & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
39694 & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
39695 & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
39696 & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
39697 & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
39698 & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
39699 & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
39700 & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
39701 & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
39702 & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
39703 & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
39704 & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
39705 & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
39706 & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
39707 & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
39708 DATA (DL(K),K= 766, 850) /
39709 & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
39710 & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
39711 & .900196E-01, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39716 & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
39717 & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
39718 & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
39719 & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
39720 & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
39721 & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
39722 & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
39723 & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
39724 & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
39725 & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
39726 DATA (DL(K),K= 851, 935) /
39727 & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
39728 & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
39729 & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
39730 & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
39731 & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
39732 & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
39733 & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
39734 & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
39735 & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
39736 & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
39737 & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
39738 & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
39739 & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
39740 & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
39741 & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
39742 & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
39743 & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
39744 DATA (DL(K),K= 936, 1020) /
39745 & .581632E-01, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39750 & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
39751 & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
39752 & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
39753 & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
39754 & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
39755 & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
39756 & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
39757 & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
39758 & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
39759 & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
39760 & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
39761 & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
39762 DATA (DL(K),K= 1021, 1105) /
39763 & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
39764 & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
39765 & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
39766 & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
39767 & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
39768 & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
39769 & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
39770 & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
39771 & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
39772 & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
39773 & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
39774 & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
39775 & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
39776 & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
39777 & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
39778 & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39779 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39780 DATA (DL(K),K= 1106, 1190) /
39781 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39782 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39783 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39784 & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
39785 & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
39786 & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
39787 & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
39788 & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
39789 & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
39790 & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
39791 & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
39792 & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
39793 & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
39794 & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
39795 & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
39796 & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
39797 & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
39798 DATA (DL(K),K= 1191, 1275) /
39799 & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
39800 & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
39801 & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
39802 & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
39803 & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
39804 & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
39805 & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
39806 & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
39807 & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
39808 & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
39809 & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
39810 & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
39811 & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
39812 & .258043E-01, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39816 DATA (DL(K),K= 1276, 1360) /
39817 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39818 & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
39819 & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
39820 & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
39821 & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
39822 & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
39823 & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
39824 & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
39825 & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
39826 & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
39827 & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
39828 & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
39829 & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
39830 & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
39831 & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
39832 & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
39833 & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
39834 DATA (DL(K),K= 1361, 1445) /
39835 & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
39836 & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
39837 & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
39838 & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
39839 & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
39840 & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
39841 & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
39842 & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
39843 & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
39844 & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
39845 & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
39846 & .184661E-01, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39851 & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
39852 DATA (DL(K),K= 1446, 1530) /
39853 & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
39854 & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
39855 & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
39856 & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
39857 & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
39858 & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
39859 & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
39860 & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
39861 & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
39862 & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
39863 & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
39864 & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
39865 & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
39866 & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
39867 & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
39868 & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
39869 & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
39870 DATA (DL(K),K= 1531, 1615) /
39871 & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
39872 & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
39873 & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
39874 & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
39875 & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
39876 & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
39877 & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
39878 & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
39879 & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
39880 & .142131E-01, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39885 & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
39886 & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
39887 & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
39888 DATA (DL(K),K= 1616, 1700) /
39889 & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
39890 & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
39891 & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
39892 & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
39893 & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
39894 & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
39895 & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
39896 & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
39897 & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
39898 & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
39899 & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
39900 & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
39901 & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
39902 & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
39903 & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
39904 & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
39905 & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
39906 DATA (DL(K),K= 1701, 1785) /
39907 & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
39908 & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
39909 & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
39910 & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
39911 & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
39912 & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
39913 & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
39914 & .113659E-01, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39919 & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
39920 & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
39921 & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
39922 & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
39923 & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
39924 DATA (DL(K),K= 1786, 1870) /
39925 & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
39926 & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
39927 & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
39928 & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
39929 & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
39930 & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
39931 & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
39932 & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
39933 & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
39934 & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
39935 & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
39936 & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
39937 & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
39938 & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
39939 & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
39940 & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
39941 & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
39942 DATA (DL(K),K= 1871, 1955) /
39943 & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
39944 & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
39945 & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
39946 & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
39947 & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
39948 & .928803E-02, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39953 & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
39954 & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
39955 & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
39956 & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
39957 & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
39958 & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
39959 & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
39960 DATA (DL(K),K= 1956, 2040) /
39961 & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
39962 & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
39963 & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
39964 & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
39965 & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
39966 & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
39967 & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
39968 & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
39969 & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
39970 & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
39971 & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
39972 & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
39973 & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
39974 & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
39975 & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
39976 & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
39977 & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
39978 DATA (DL(K),K= 2041, 2125) /
39979 & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
39980 & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
39981 & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
39982 & .768059E-02, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39987 & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
39988 & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
39989 & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
39990 & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
39991 & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
39992 & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
39993 & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
39994 & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
39995 & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
39996 DATA (DL(K),K= 2126, 2210) /
39997 & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
39998 & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
39999 & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
40000 & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
40001 & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
40002 & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
40003 & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
40004 & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
40005 & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
40006 & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
40007 & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
40008 & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
40009 & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
40010 & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
40011 & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
40012 & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
40013 & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
40014 DATA (DL(K),K= 2211, 2295) /
40015 & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
40016 & .638332E-02, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40021 & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
40022 & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
40023 & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
40024 & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
40025 & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
40026 & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
40027 & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
40028 & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
40029 & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
40030 & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
40031 & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
40032 DATA (DL(K),K= 2296, 2380) /
40033 & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
40034 & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
40035 & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
40036 & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
40037 & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
40038 & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
40039 & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
40040 & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
40041 & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
40042 & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
40043 & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
40044 & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
40045 & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
40046 & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
40047 & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
40048 & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
40049 & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40050 DATA (DL(K),K= 2381, 2465) /
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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40055 & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40056 & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40057 & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40058 & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40059 & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40060 & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40061 & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40062 & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40063 & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40064 & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40065 & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40066 & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40067 & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40068 DATA (DL(K),K= 2466, 2550) /
40069 & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40070 & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40071 & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40072 & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40073 & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40074 & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40075 & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40076 & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40077 & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40078 & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40079 & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40080 & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40081 & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40082 & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40083 & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40084 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40085 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40086 DATA (DL(K),K= 2551, 2635) /
40087 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40088 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40089 & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40090 & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40091 & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40092 & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40093 & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40094 & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40095 & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40096 & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40097 & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40098 & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40099 & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40100 & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40101 & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40102 & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40103 & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40104 DATA (DL(K),K= 2636, 2720) /
40105 & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40106 & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40107 & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40108 & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40109 & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40110 & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40111 & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40112 & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40113 & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40114 & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40115 & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40116 & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40117 & .358213E-02, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40122 DATA (DL(K),K= 2721, 2805) /
40123 & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40124 & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40125 & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40126 & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40127 & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40128 & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40129 & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40130 & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40131 & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40132 & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40133 & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40134 & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40135 & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40136 & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40137 & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40138 & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40139 & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40140 DATA (DL(K),K= 2806, 2890) /
40141 & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40142 & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40143 & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40144 & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40145 & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40146 & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40147 & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40148 & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40149 & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40150 & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40151 & .288164E-02, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40156 & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40157 & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40158 DATA (DL(K),K= 2891, 2975) /
40159 & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40160 & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40161 & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40162 & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40163 & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40164 & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40165 & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40166 & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40167 & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40168 & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40169 & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40170 & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40171 & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40172 & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40173 & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40174 & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40175 & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40176 DATA (DL(K),K= 2976, 3060) /
40177 & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40178 & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40179 & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40180 & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40181 & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40182 & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40183 & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40184 & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40185 & .226473E-02, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40190 & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40191 & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40192 & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40193 & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40194 DATA (DL(K),K= 3061, 3145) /
40195 & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40196 & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40197 & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40198 & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40199 & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40200 & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40201 & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40202 & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40203 & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40204 & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40205 & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40206 & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40207 & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40208 & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40209 & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40210 & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40211 & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40212 DATA (DL(K),K= 3146, 3230) /
40213 & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40214 & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40215 & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40216 & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40217 & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40218 & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40219 & .172225E-02, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40224 & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40225 & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40226 & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40227 & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40228 & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40229 & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40230 DATA (DL(K),K= 3231, 3315) /
40231 & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40232 & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40233 & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40234 & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40235 & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40236 & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40237 & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40238 & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40239 & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40240 & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40241 & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40242 & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40243 & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40244 & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40245 & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40246 & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40247 & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40248 DATA (DL(K),K= 3316, 3400) /
40249 & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40250 & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40251 & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40252 & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40253 & .124955E-02, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40258 & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40259 & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40260 & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40261 & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40262 & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40263 & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40264 & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40265 & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40266 DATA (DL(K),K= 3401, 3485) /
40267 & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40268 & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40269 & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40270 & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40271 & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40272 & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40273 & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40274 & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40275 & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40276 & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40277 & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40278 & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40279 & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40280 & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40281 & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40282 & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40283 & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40284 DATA (DL(K),K= 3486, 3570) /
40285 & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40286 & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40287 & .845361E-03, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40292 & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40293 & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40294 & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40295 & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40296 & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40297 & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40298 & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40299 & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40300 & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40301 & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40302 DATA (DL(K),K= 3571, 3655) /
40303 & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40304 & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40305 & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40306 & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40307 & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40308 & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40309 & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40310 & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40311 & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40312 & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40313 & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40314 & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40315 & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40316 & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40317 & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40318 & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40319 & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40320 DATA (DL(K),K= 3656, 3740) /
40321 & .511392E-03, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40326 & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40327 & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40328 & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40329 & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40330 & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40331 & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40332 & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40333 & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40334 & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40335 & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40336 & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40337 & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40338 DATA (DL(K),K= 3741, 3825) /
40339 & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40340 & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40341 & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40342 & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40343 & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40344 & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40345 & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40346 & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40347 & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40348 & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40349 & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40350 & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40351 & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40352 & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40353 & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40354 & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40355 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40356 DATA (DL(K),K= 3826, 3910) /
40357 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40358 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40359 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40360 & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40361 & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40362 & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40363 & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40364 & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40365 & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40366 & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40367 & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40368 & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40369 & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40370 & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40371 & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40372 & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40373 & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40374 DATA (DL(K),K= 3911, 3995) /
40375 & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40376 & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40377 & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40378 & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40379 & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40380 & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40381 & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40382 & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40383 & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40384 & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40385 & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40386 & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40387 & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40388 & .747649E-04, .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 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40392 DATA (DL(K),K= 3996, 4000) /
40393 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40394
40395 DO 10 I=1,7
40396 QQ(I) = 0.
40397 10 CONTINUE
40398 IF(X.GT.0.9985) RETURN
40399
40400 IS = S/DELTA+1
40401 IS = MIN(IS,19)
40402 IS1 = IS+1
40403 DO 20 I=1,7
40404 IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40405 IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40406 DO 30 L=1,25
40407 F1(L)=GF(I,IS,L)
40408 F2(L)=GF(I,IS1,L)
40409 30 CONTINUE
40410 S1=(IS-1)*DELTA
40411 S2=S1+DELTA
40412 A1 = PHO_CKMTFV(X,F1)
40413 A2 = PHO_CKMTFV(X,F2)
40414 QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40415 19 CONTINUE
40416 20 CONTINUE
40417
40418 END
40419
40420CDECK ID>, PHO_CKMTFV
40421 REAL FUNCTION PHO_CKMTFV(X,FVL)
40422C**********************************************************************
40423C
40424C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40425C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40426C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40427C IN MAIN ROUTINE.
40428C
40429C**********************************************************************
40430 SAVE
40431
40432 DIMENSION FVL(25),XGRID(25)
40433
40434C input/output channels
40435 INTEGER LI,LO
40436 COMMON /POINOU/ LI,LO
40437
40438 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40439 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40440
40441 PHO_CKMTFV=0.
40442 DO 1 I=1,NX
40443 IF(X.LT.XGRID(I)) GO TO 2
40444 1 CONTINUE
40445 2 I=I-1
40446 IF(I.EQ.0) THEN
40447 I=I+1
40448 ELSE IF(I.GT.23) THEN
40449 I=23
40450 ENDIF
40451 J=I+1
40452 K=J+1
40453 AXI=LOG(XGRID(I))
40454 BXI=LOG(1.-XGRID(I))
40455 AXJ=LOG(XGRID(J))
40456 BXJ=LOG(1.-XGRID(J))
40457 AXK=LOG(XGRID(K))
40458 BXK=LOG(1.-XGRID(K))
40459 FI=LOG(ABS(FVL(I)) +1.E-15)
40460 FJ=LOG(ABS(FVL(J)) +1.E-16)
40461 FK=LOG(ABS(FVL(K)) +1.E-17)
40462 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40463 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40464 $ BXI))/DET
40465 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40466 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40467 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40468 1RETURN
40469C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40470C WRITE(LO,2001) X,FVL
40471C 2001 FORMAT(8E12.4)
40472C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40473C ENDIF
40474 PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40475
40476 END
40477
40478CDECK ID>, PHO_SASGAM
40479C***********************************************************************
40480C...SaSgam version 2 - parton distributions of the photon
40481C...by Gerhard A. Schuler and Torbjorn Sjostrand
40482C...For further information see Z. Phys. C68 (1995) 607
40483C...and Phys. Lett. B376 (1996) 193.
40484
40485C...18 January 1996: original code.
40486C...22 July 1996: calculation of BETA moved in SASBEH.
40487
40488C!!!Note that one further call parameter - IP2 - has been added
40489C!!!to the SASGAM argument list compared with version 1.
40490
40491C...The user should only need to call the SASGAM routine,
40492C...which in turn calls the auxiliary routines SASVMD, SASANO,
40493C...SASBEH and SASDIR. The package is self-contained.
40494
40495C...One particular aspect of these parametrizations is that F2 for
40496C...the photon is not obtained just as the charge-squared-weighted
40497C...sum of quark distributions, but differ in the treatment of
40498C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40499C...the kinematics range of heavy-flavour production, but the same
40500C...kinematics is not relevant e.g. for jet production) and, for the
40501C...'MSbar' fits, in the addition of a Cgamma term related to the
40502C...separation of direct processes. Schematically:
40503C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40504C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
40505C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40506C...The J/psi and Upsilon states have not been included in the VMD sum,
40507C...but low c and b masses in the other components should compensate
40508C...for this in a duality sense.
40509
40510C...The calling sequence is the following:
40511C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40512C...with the following declaration statement:
40513C DIMENSION XPDFGM(-6:6)
40514C...and, optionally, further information in:
40515C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40516C &XPDIR(-6:6)
40517C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40518C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
40519C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40520C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
40521C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
40522C X : x value.
40523C Q2 : Q2 value.
40524C P2 : P2 value; should be = 0. for an on-shell photon.
40525C IP2 : scheme used to evaluate off-shell anomalous component.
40526C = 0 : recommended default, see = 7.
40527C = 1 : dipole dampening by integration; very time-consuming.
40528C = 2 : P_0^2 = max( Q_0^2, P^2 )
40529C = 3 : P_0^2 = Q_0^2 + P^2.
40530C = 4 : P_{eff} that preserves momentum sum.
40531C = 5 : P_{int} that preserves momentum and average
40532C evolution range.
40533C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40534C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40535C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40536C XPFDGM : x times parton distribution functions of the photon,
40537C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40538C 6 = t (always empty!), - for antiquarks (result is same).
40539C...The breakdown by component is stored in the commonblock SASCOM,
40540C with elements as above.
40541C XPVMD : rho, omega, phi VMD part only of output.
40542C XPANL : d, u, s anomalous part only of output.
40543C XPANH : c, b anomalous part only of output.
40544C XPBEH : c, b Bethe-Heitler part only of output.
40545C XPDIR : Cgamma (direct contribution) part only of output.
40546C...The above arrays do not distinguish valence and sea contributions,
40547C...although this information is available internally. The additional
40548C...commonblock SASVAL provides the valence part only of the above
40549C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40550C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40551C...and therefore not given doubly. VXPDGM gives the sum of valence
40552C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40553C...and so on, gives the sea part only.
40554C***********************************************************************
40555
40556 SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40557C...Purpose: to construct the F2 and parton distributions of the photon
40558C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40559C...For F2, c and b are included by the Bethe-Heitler formula;
40560C...in the 'MSbar' scheme additionally a Cgamma term is added.
40561 SAVE
40562 DIMENSION XPDFGM(-6:6)
40563
40564C input/output channels
40565 INTEGER LI,LO
40566 COMMON /POINOU/ LI,LO
40567
40568 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40569 &XPDIR(-6:6)
40570 COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40571 SAVE /SASCOM/,/SASVAL/
40572
40573C...Temporary array.
40574 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40575C...Charm and bottom masses (low to compensate for J/psi etc.).
40576 DATA PMC/1.3/, PMB/4.6/
40577C...alpha_em and alpha_em/(2*pi).
40578 DATA AEM/0.007297/, AEM2PI/0.0011614/
40579C...Lambda value for 4 flavours.
40580 DATA ALAM/0.20/
40581C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40582 DATA FRACU/0.8/
40583C...VMD couplings f_V**2/(4*pi).
40584 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40585C...Masses for rho (=omega) and phi.
40586 DATA PMRHO/0.770/, PMPHI/1.020/
40587C...Number of points in integration for IP2=1.
40588 DATA NSTEP/100/
40589
40590C...Reset output.
40591 F2GM=0.
40592 DO 100 KFL=-6,6
40593 XPDFGM(KFL)=0.
40594 XPVMD(KFL)=0.
40595 XPANL(KFL)=0.
40596 XPANH(KFL)=0.
40597 XPBEH(KFL)=0.
40598 XPDIR(KFL)=0.
40599 VXPVMD(KFL)=0.
40600 VXPANL(KFL)=0.
40601 VXPANH(KFL)=0.
40602 VXPDGM(KFL)=0.
40603 100 CONTINUE
40604
40605C...Check that input sensible.
40606 IF(ISET.LE.0.OR.ISET.GE.5) THEN
40607 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
40608 WRITE(LO,*) ' ISET = ',ISET
40609 STOP
40610 ENDIF
40611 IF(X.LE.0..OR.X.GT.1.) THEN
40612 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
40613 WRITE(LO,*) ' X = ',X
40614 STOP
40615 ENDIF
40616
40617C...Set Q0 cut-off parameter as function of set used.
40618 IF(ISET.LE.2) THEN
40619 Q0=0.6
40620 ELSE
40621 Q0=2.
40622 ENDIF
40623 Q02=Q0**2
40624
40625C...Scale choice for off-shell photon; common factors.
40626 Q2A=Q2
40627 FACNOR=1.
40628 IF(IP2.EQ.1) THEN
40629 P2MX=P2+Q02
40630 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40631 FACNOR=LOG(Q2/Q02)/NSTEP
40632 ELSEIF(IP2.EQ.2) THEN
40633 P2MX=MAX(P2,Q02)
40634 ELSEIF(IP2.EQ.3) THEN
40635 P2MX=P2+Q02
40636 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40637 ELSEIF(IP2.EQ.4) THEN
40638 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40639 & ((Q2+P2)*(Q02+P2)))
40640 ELSEIF(IP2.EQ.5) THEN
40641 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40642 & ((Q2+P2)*(Q02+P2)))
40643 P2MX=Q0*SQRT(P2MXA)
40644 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40645 ELSEIF(IP2.EQ.6) THEN
40646 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40647 & ((Q2+P2)*(Q02+P2)))
40648 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40649 ELSE
40650 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40651 & ((Q2+P2)*(Q02+P2)))
40652 P2MX=Q0*SQRT(P2MXA)
40653 P2MXB=P2MX
40654 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40655 P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
40656 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40657 ENDIF
40658
40659C...Call VMD parametrization for d quark and use to give rho, omega,
40660C...phi. Note dipole dampening for off-shell photon.
40661 CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40662 XFVAL=VXPGA(1)
40663 XPGA(1)=XPGA(2)
40664 XPGA(-1)=XPGA(-2)
40665 FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40666 FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40667 DO 110 KFL=-5,5
40668 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40669 110 CONTINUE
40670 XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
40671 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40672 XPVMD(3)=XPVMD(3)+FACS*XFVAL
40673 XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
40674 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40675 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40676 VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
40677 VXPVMD(2)=FRACU*FACUD*XFVAL
40678 VXPVMD(3)=FACS*XFVAL
40679 VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
40680 VXPVMD(-2)=FRACU*FACUD*XFVAL
40681 VXPVMD(-3)=FACS*XFVAL
40682
40683 IF(IP2.NE.1) THEN
40684C...Anomalous parametrizations for different strategies
40685C...for off-shell photons; except full integration.
40686
40687C...Call anomalous parametrization for d + u + s.
40688 CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40689 DO 120 KFL=-5,5
40690 XPANL(KFL)=FACNOR*XPGA(KFL)
40691 VXPANL(KFL)=FACNOR*VXPGA(KFL)
40692 120 CONTINUE
40693
40694C...Call anomalous parametrization for c and b.
40695 CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40696 DO 130 KFL=-5,5
40697 XPANH(KFL)=FACNOR*XPGA(KFL)
40698 VXPANH(KFL)=FACNOR*VXPGA(KFL)
40699 130 CONTINUE
40700 CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40701 DO 140 KFL=-5,5
40702 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40703 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40704 140 CONTINUE
40705
40706 ELSE
40707C...Special option: loop over flavours and integrate over k2.
40708 DO 170 KF=1,5
40709 DO 160 ISTEP=1,NSTEP
40710 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
40711 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40712 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40713 CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40714 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40715 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
40716 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
40717 DO 150 KFL=-5,5
40718 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40719 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40720 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40721 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40722 150 CONTINUE
40723 160 CONTINUE
40724 170 CONTINUE
40725 ENDIF
40726
40727C...Call Bethe-Heitler term expression for charm and bottom.
40728 CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
40729 XPBEH(4)=XPBH
40730 XPBEH(-4)=XPBH
40731 CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
40732 XPBEH(5)=XPBH
40733 XPBEH(-5)=XPBH
40734
40735C...For MSbar subtraction call C^gamma term expression for d, u, s.
40736 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40737 CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
40738 DO 180 KFL=-5,5
40739 XPDIR(KFL)=XPGA(KFL)
40740 180 CONTINUE
40741 ENDIF
40742
40743C...Store result in output array.
40744 DO 190 KFL=-5,5
40745 CHSQ=1./9.
40746 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
40747 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40748 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40749 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40750 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40751 190 CONTINUE
40752
40753 RETURN
40754 END
40755
40756C*********************************************************************
40757
40758CDECK ID>, PHO_SASVMD
40759 SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40760C...Purpose: to evaluate the VMD parton distributions of a photon,
40761C...evolved homogeneously from an initial scale P2 to Q2.
40762C...Does not include dipole suppression factor.
40763C...ISET is parton distribution set, see above;
40764C...additionally ISET=0 is used for the evolution of an anomalous photon
40765C...which branched at a scale P2 and then evolved homogeneously to Q2.
40766C...ALAM is the 4-flavour Lambda, which is automatically converted
40767C...to 3- and 5-flavour equivalents as needed.
40768 SAVE
40769 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40770
40771C input/output channels
40772 INTEGER LI,LO
40773 COMMON /POINOU/ LI,LO
40774
40775 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40776
40777C...Reset output.
40778 DO 100 KFL=-6,6
40779 XPGA(KFL)=0.
40780 VXPGA(KFL)=0.
40781 100 CONTINUE
40782 KFA=IABS(KF)
40783
40784C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40785 ALAM3=ALAM*(PMC/ALAM)**(2./27.)
40786 ALAM5=ALAM*(ALAM/PMB)**(2./23.)
40787 P2EFF=MAX(P2,1.2*ALAM3**2)
40788 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40789 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40790 Q2EFF=MAX(Q2,P2EFF)
40791
40792C...Find number of flavours at lower and upper scale.
40793 NFP=4
40794 IF(P2EFF.LT.PMC**2) NFP=3
40795 IF(P2EFF.GT.PMB**2) NFP=5
40796 NFQ=4
40797 IF(Q2EFF.LT.PMC**2) NFQ=3
40798 IF(Q2EFF.GT.PMB**2) NFQ=5
40799
40800C...Find s as sum of 3-, 4- and 5-flavour parts.
40801 S=0.
40802 IF(NFP.EQ.3) THEN
40803 Q2DIV=PMC**2
40804 IF(NFQ.EQ.3) Q2DIV=Q2EFF
40805 S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40806 ENDIF
40807 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40808 P2DIV=P2EFF
40809 IF(NFP.EQ.3) P2DIV=PMC**2
40810 Q2DIV=Q2EFF
40811 IF(NFQ.EQ.5) Q2DIV=PMB**2
40812 S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40813 ENDIF
40814 IF(NFQ.EQ.5) THEN
40815 P2DIV=PMB**2
40816 IF(NFP.EQ.5) P2DIV=P2EFF
40817 S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40818 ENDIF
40819
40820C...Calculate frequent combinations of x and s.
40821 X1=1.-X
40822 XL=-LOG(X)
40823 S2=S**2
40824 S3=S**3
40825 S4=S**4
40826
40827C...Evaluate homogeneous anomalous parton distributions below or
40828C...above threshold.
40829 IF(ISET.EQ.0) THEN
40830 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40831 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40832 XVAL = X * 1.5 * (X**2+X1**2)
40833 XGLU = 0.
40834 XSEA = 0.
40835 ELSE
40836 XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
40837 & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
40838 & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
40839 XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
40840 & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
40841 & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
40842 XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
40843 & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
40844 & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
40845 & (2.*X-1.)*X*XL**2)
40846 ENDIF
40847
40848C...Evaluate set 1D parton distributions below or above threshold.
40849 ELSEIF(ISET.EQ.1) THEN
40850 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40851 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40852 XVAL = 1.294 * X**0.80 * X1**0.76
40853 XGLU = 1.273 * X**0.40 * X1**1.76
40854 XSEA = 0.100 * X1**3.76
40855 ELSE
40856 XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
40857 & X1**(0.76+0.667*S) * XL**(2.*S)
40858 XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
40859 & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
40860 & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
40861 XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
40862 & X**(-7.32*S2/(1.+10.3*S2)) *
40863 & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
40864 XSEA0 = 0.100 * X1**3.76
40865 ENDIF
40866
40867C...Evaluate set 1M parton distributions below or above threshold.
40868 ELSEIF(ISET.EQ.2) THEN
40869 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40870 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40871 XVAL = 0.8477 * X**0.51 * X1**1.37
40872 XGLU = 3.42 * X**0.255 * X1**2.37
40873 XSEA = 0.
40874 ELSE
40875 XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
40876 & * X1**1.37 * XL**(2.667*S)
40877 XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
40878 & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
40879 & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
40880 & X1**(2.37+3.*S)
40881 XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
40882 & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
40883 & XL**(2.8*S)
40884 XSEA0 = 0.
40885 ENDIF
40886
40887C...Evaluate set 2D parton distributions below or above threshold.
40888 ELSEIF(ISET.EQ.3) THEN
40889 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40890 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40891 XVAL = X**0.46 * X1**0.64 + 0.76 * X
40892 XGLU = 1.925 * X1**2
40893 XSEA = 0.242 * X1**4
40894 ELSE
40895 XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
40896 & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
40897 & (0.76+0.4*S) * X * X1**(2.667*S)
40898 XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
40899 & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
40900 & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
40901 XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
40902 & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
40903 XSEA0 = 0.242 * X1**4
40904 ENDIF
40905
40906C...Evaluate set 2M parton distributions below or above threshold.
40907 ELSEIF(ISET.EQ.4) THEN
40908 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40909 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40910 XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
40911 XGLU = 1.808 * X1**2
40912 XSEA = 0.209 * X1**4
40913 ELSE
40914 XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
40915 & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
40916 & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
40917 & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
40918 XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
40919 & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
40920 & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
40921 & XL**(10.9*S/(1.+2.5*S))
40922 XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
40923 & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
40924 & X1**(4.+S) * XL**(0.45*S)
40925 XSEA0 = 0.209 * X1**4
40926 ENDIF
40927 ENDIF
40928
40929C...Threshold factors for c and b sea.
40930 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40931 XCHM=0.
40932 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
40933 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40934 IF(ISET.EQ.0) THEN
40935 XCHM=XSEA*(1.-(SCH/SLL)**2)
40936 ELSE
40937 XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
40938 ENDIF
40939 ENDIF
40940 XBOT=0.
40941 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
40942 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40943 IF(ISET.EQ.0) THEN
40944 XBOT=XSEA*(1.-(SBT/SLL)**2)
40945 ELSE
40946 XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
40947 ENDIF
40948 ENDIF
40949
40950C...Fill parton distributions.
40951 XPGA(0)=XGLU
40952 XPGA(1)=XSEA
40953 XPGA(2)=XSEA
40954 XPGA(3)=XSEA
40955 XPGA(4)=XCHM
40956 XPGA(5)=XBOT
40957 XPGA(KFA)=XPGA(KFA)+XVAL
40958 DO 110 KFL=1,5
40959 XPGA(-KFL)=XPGA(KFL)
40960 110 CONTINUE
40961 VXPGA(KFA)=XVAL
40962 VXPGA(-KFA)=XVAL
40963
40964 RETURN
40965 END
40966
40967C*********************************************************************
40968
40969CDECK ID>, PHO_SASANO
40970 SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40971C...Purpose: to evaluate the parton distributions of the anomalous
40972C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
40973C...to Q2.
40974C...KF=0 gives the sum over (up to) 5 flavours,
40975C...KF<0 limits to flavours up to abs(KF),
40976C...KF>0 is for flavour KF only.
40977C...ALAM is the 4-flavour Lambda, which is automatically converted
40978C...to 3- and 5-flavour equivalents as needed.
40979 SAVE
40980
40981C input/output channels
40982 INTEGER LI,LO
40983 COMMON /POINOU/ LI,LO
40984
40985 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40986 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40987
40988C...Reset output.
40989 DO 100 KFL=-6,6
40990 XPGA(KFL)=0.
40991 VXPGA(KFL)=0.
40992 100 CONTINUE
40993 IF(Q2.LE.P2) RETURN
40994 KFA=IABS(KF)
40995
40996C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40997 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
40998 ALAMSQ(4)=ALAM**2
40999 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
41000 P2EFF=MAX(P2,1.2*ALAMSQ(3))
41001 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
41002 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
41003 Q2EFF=MAX(Q2,P2EFF)
41004 XL=-LOG(X)
41005
41006C...Find number of flavours at lower and upper scale.
41007 NFP=4
41008 IF(P2EFF.LT.PMC**2) NFP=3
41009 IF(P2EFF.GT.PMB**2) NFP=5
41010 NFQ=4
41011 IF(Q2EFF.LT.PMC**2) NFQ=3
41012 IF(Q2EFF.GT.PMB**2) NFQ=5
41013
41014C...Define range of flavour loop.
41015 IF(KF.EQ.0) THEN
41016 KFLMN=1
41017 KFLMX=5
41018 ELSEIF(KF.LT.0) THEN
41019 KFLMN=1
41020 KFLMX=KFA
41021 ELSE
41022 KFLMN=KFA
41023 KFLMX=KFA
41024 ENDIF
41025
41026C...Loop over flavours the photon can branch into.
41027 DO 110 KFL=KFLMN,KFLMX
41028
41029C...Light flavours: calculate t range and (approximate) s range.
41030 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
41031 TDIFF=LOG(Q2EFF/P2EFF)
41032 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41033 & LOG(P2EFF/ALAMSQ(NFQ)))
41034 IF(NFQ.GT.NFP) THEN
41035 Q2DIV=PMB**2
41036 IF(NFQ.EQ.4) Q2DIV=PMC**2
41037 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41038 & LOG(P2EFF/ALAMSQ(NFQ)))
41039 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41040 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41041 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41042 ENDIF
41043 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41044 Q2DIV=PMC**2
41045 SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41046 & LOG(P2EFF/ALAMSQ(4)))
41047 SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41048 & LOG(P2EFF/ALAMSQ(3)))
41049 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41050 ENDIF
41051
41052C...u and s quark do not need a separate treatment when d has been done.
41053 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41054
41055C...Charm: as above, but only include range above c threshold.
41056 ELSEIF(KFL.EQ.4) THEN
41057 IF(Q2.LE.PMC**2) GOTO 110
41058 P2EFF=MAX(P2EFF,PMC**2)
41059 Q2EFF=MAX(Q2EFF,P2EFF)
41060 TDIFF=LOG(Q2EFF/P2EFF)
41061 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41062 & LOG(P2EFF/ALAMSQ(NFQ)))
41063 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41064 Q2DIV=PMB**2
41065 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41066 & LOG(P2EFF/ALAMSQ(NFQ)))
41067 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41068 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41069 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41070 ENDIF
41071
41072C...Bottom: as above, but only include range above b threshold.
41073 ELSEIF(KFL.EQ.5) THEN
41074 IF(Q2.LE.PMB**2) GOTO 110
41075 P2EFF=MAX(P2EFF,PMB**2)
41076 Q2EFF=MAX(Q2,P2EFF)
41077 TDIFF=LOG(Q2EFF/P2EFF)
41078 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41079 & LOG(P2EFF/ALAMSQ(NFQ)))
41080 ENDIF
41081
41082C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41083 CHSQ=1./9.
41084 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41085 FAC=AEM2PI*2.*CHSQ*TDIFF
41086
41087C...Evaluate parton distributions (normalized to unit momentum sum).
41088 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41089 XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41090 & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41091 & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41092 & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41093 XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41094 & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41095 & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41096 XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41097 & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41098 & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41099 & (2.*X-1.)*X*XL**2)
41100
41101C...Threshold factors for c and b sea.
41102 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41103 XCHM=0.
41104 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41105 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41106 XCHM=XSEA*(1.-(SCH/SLL)**3)
41107 ENDIF
41108 XBOT=0.
41109 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41110 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41111 XBOT=XSEA*(1.-(SBT/SLL)**3)
41112 ENDIF
41113 ENDIF
41114
41115C...Add contribution of each valence flavour.
41116 XPGA(0)=XPGA(0)+FAC*XGLU
41117 XPGA(1)=XPGA(1)+FAC*XSEA
41118 XPGA(2)=XPGA(2)+FAC*XSEA
41119 XPGA(3)=XPGA(3)+FAC*XSEA
41120 XPGA(4)=XPGA(4)+FAC*XCHM
41121 XPGA(5)=XPGA(5)+FAC*XBOT
41122 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41123 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41124 110 CONTINUE
41125 DO 120 KFL=1,5
41126 XPGA(-KFL)=XPGA(KFL)
41127 VXPGA(-KFL)=VXPGA(KFL)
41128 120 CONTINUE
41129
41130 END
41131
41132C*********************************************************************
41133
41134CDECK ID>, PHO_SASBEH
41135 SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41136C...Purpose: to evaluate the Bethe-Heitler cross section for
41137C...heavy flavour production.
41138 SAVE
41139 DATA AEM2PI/0.0011614/
41140
41141C...Reset output.
41142 XPBH=0.
41143 SIGBH=0.
41144
41145C...Check kinematics limits.
41146 IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41147 W2=Q2*(1.-X)/X-P2
41148 BETA2=1.-4.*PM2/W2
41149 IF(BETA2.LT.1E-10) RETURN
41150 BETA=SQRT(BETA2)
41151 RMQ=4.*PM2/Q2
41152
41153C...Simple case: P2 = 0.
41154 IF(P2.LT.1E-4) THEN
41155 IF(BETA.LT.0.99) THEN
41156 XBL=LOG((1.+BETA)/(1.-BETA))
41157 ELSE
41158 XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41159 ENDIF
41160 SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41161 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41162
41163C...Complicated case: P2 > 0, based on approximation of
41164C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41165 ELSE
41166 RPQ=1.-4.*X**2*P2/Q2
41167 IF(RPQ.GT.1E-10) THEN
41168 RPBE=SQRT(RPQ*BETA2)
41169 IF(RPBE.LT.0.99) THEN
41170 XBL=LOG((1.+RPBE)/(1.-RPBE))
41171 XBI=2.*RPBE/(1.-RPBE**2)
41172 ELSE
41173 RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41174 XBL=LOG((1.+RPBE)**2/RPBESN)
41175 XBI=2.*RPBE/RPBESN
41176 ENDIF
41177 SIGBH=BETA*(6.*X*(1.-X)-1.)+
41178 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41179 & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41180 ENDIF
41181 ENDIF
41182
41183C...Multiply by charge-squared etc. to get parton distribution.
41184 CHSQ=1./9.
41185 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41186 XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41187
41188 END
41189
41190C*********************************************************************
41191
41192CDECK ID>, PHO_SASDIR
41193 SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41194C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41195C...as needed in MSbar parametrizations.
41196 SAVE
41197 DIMENSION XPGA(-6:6)
41198 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41199
41200C...Reset output.
41201 DO 100 KFL=-6,6
41202 XPGA(KFL)=0.
41203 100 CONTINUE
41204
41205C...Evaluate common x-dependent expression.
41206 XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41207 CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41208
41209C...d, u, s part by simple charge factor.
41210 XPGA(1)=(1./9.)*CGAM
41211 XPGA(2)=(4./9.)*CGAM
41212 XPGA(3)=(1./9.)*CGAM
41213
41214C...Also fill for antiquarks.
41215 DO 110 KF=1,5
41216 XPGA(-KF)=XPGA(KF)
41217 110 CONTINUE
41218
41219 END
41220
41221CDECK ID>, PHO_PHGAL
41222 SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41223C***********************************************************************
41224C
41225C photon parton densities with built-in momentum sum rule and
41226C Regge-based low-x behaviour
41227C
41228C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41229C e-Print Archive: hep-ph/9711355
41230C
41231C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41232C
41233C***********************************************************************
41234 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41235 SAVE
41236
41237 PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41238 DOUBLE PRECISION
41239 & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41240 & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41241
41242 DIMENSION NA(NARG)
41243
41244 DATA ZEROD/0.D0/
41245
41246C...100 x values; in (D-4,.77) log spaced (78 points)
41247C... in (.78,.995) lineary spaced (22 points)
41248 DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41249 DATA XT/
41250 &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41251 &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41252 &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41253 &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41254 &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41255 &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41256 &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41257 &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41258 &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41259 &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41260 &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41261 &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41262 &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41263 &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41264 &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41265 &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41266 &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41267
41268C...place for DATA blocks
41269 DATA (XPV(I,1,0),I=1,100)/
41270 &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41271 &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41272 &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41273 &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41274 &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41275 &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41276 &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41277 &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41278 &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41279 &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41280 &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41281 &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41282 &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41283 &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41284 &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41285 &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41286 &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41287 DATA (XPV(I,1,1),I=1,100)/
41288 &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41289 &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41290 &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41291 &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41292 &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41293 &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41294 &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41295 &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41296 &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41297 &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41298 &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41299 &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41300 &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41301 &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41302 &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41303 &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41304 &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41305 DATA (XPV(I,1,2),I=1,100)/
41306 &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41307 &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41308 &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41309 &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41310 &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41311 &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41312 &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41313 &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41314 &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41315 &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41316 &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41317 &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41318 &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41319 &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41320 &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41321 &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41322 &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41323 DATA (XPV(I,1,3),I=1,100)/
41324 &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41325 &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41326 &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41327 &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41328 &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41329 &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41330 &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41331 &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41332 &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41333 &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41334 &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41335 &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41336 &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41337 &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41338 &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41339 &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41340 &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41341 DATA (XPV(I,1,4),I=1,100)/
41342 &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41343 &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41344 &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41345 &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41346 &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41347 &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41348 &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41349 &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41350 &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41351 &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41352 &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41353 &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41354 &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41355 &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41356 &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41357 &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41358 &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41359 DATA (XPV(I,2,0),I=1,100)/
41360 &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41361 &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41362 &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41363 &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41364 &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41365 &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41366 &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41367 &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41368 &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41369 &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41370 &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41371 &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41372 &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41373 &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41374 &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41375 &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41376 &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41377 DATA (XPV(I,2,1),I=1,100)/
41378 &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41379 &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41380 &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41381 &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41382 &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41383 &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41384 &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41385 &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41386 &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41387 &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41388 &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41389 &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41390 &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41391 &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41392 &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41393 &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41394 &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41395 DATA (XPV(I,2,2),I=1,100)/
41396 &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41397 &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41398 &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41399 &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41400 &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41401 &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41402 &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41403 &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41404 &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41405 &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41406 &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41407 &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41408 &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41409 &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41410 &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41411 &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41412 &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41413 DATA (XPV(I,2,3),I=1,100)/
41414 &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41415 &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41416 &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41417 &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41418 &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41419 &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41420 &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41421 &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41422 &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41423 &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41424 &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41425 &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41426 &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41427 &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41428 &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41429 &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41430 &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41431 DATA (XPV(I,2,4),I=1,100)/
41432 &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41433 &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41434 &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41435 &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41436 &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41437 &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41438 &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41439 &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41440 &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41441 &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41442 &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41443 &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41444 &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41445 &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41446 &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41447 &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41448 &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41449 DATA (XPV(I,3,0),I=1,100)/
41450 &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41451 &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41452 &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41453 &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41454 &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41455 &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41456 &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41457 &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41458 &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41459 &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41460 &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41461 &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41462 &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41463 &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41464 &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41465 &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41466 &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41467 DATA (XPV(I,3,1),I=1,100)/
41468 &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41469 &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41470 &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41471 &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41472 &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41473 &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41474 &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41475 &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41476 &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41477 &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41478 &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41479 &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41480 &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41481 &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41482 &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41483 &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41484 &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41485 DATA (XPV(I,3,2),I=1,100)/
41486 &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41487 &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41488 &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41489 &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41490 &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41491 &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41492 &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41493 &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41494 &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41495 &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41496 &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41497 &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41498 &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41499 &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41500 &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41501 &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41502 &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41503 DATA (XPV(I,3,3),I=1,100)/
41504 &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41505 &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41506 &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41507 &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41508 &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41509 &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41510 &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41511 &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41512 &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41513 &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41514 &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41515 &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41516 &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41517 &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41518 &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41519 &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41520 &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41521 DATA (XPV(I,3,4),I=1,100)/
41522 &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41523 &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41524 &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41525 &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41526 &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41527 &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41528 &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41529 &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41530 &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41531 &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41532 &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41533 &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41534 &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41535 &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41536 &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41537 &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41538 &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41539 DATA (XPV(I,4,0),I=1,100)/
41540 &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41541 &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41542 &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41543 &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41544 &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41545 &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41546 &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41547 &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41548 &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41549 &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41550 &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41551 &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41552 &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41553 &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41554 &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41555 &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41556 &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41557 DATA (XPV(I,4,1),I=1,100)/
41558 &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41559 &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41560 &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41561 &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41562 &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41563 &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41564 &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41565 &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41566 &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41567 &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41568 &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41569 &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41570 &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41571 &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41572 &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41573 &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41574 &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41575 DATA (XPV(I,4,2),I=1,100)/
41576 &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41577 &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41578 &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41579 &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41580 &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41581 &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41582 &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41583 &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41584 &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41585 &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41586 &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41587 &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41588 &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41589 &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
41590 &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
41591 &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
41592 &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
41593 DATA (XPV(I,4,3),I=1,100)/
41594 &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
41595 &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
41596 &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
41597 &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
41598 &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
41599 &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
41600 &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
41601 &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
41602 &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
41603 &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
41604 &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
41605 &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
41606 &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
41607 &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
41608 &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
41609 &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
41610 &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
41611 DATA (XPV(I,4,4),I=1,100)/
41612 &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
41613 &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
41614 &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
41615 &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
41616 &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
41617 &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
41618 &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
41619 &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
41620 &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
41621 &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
41622 &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
41623 &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
41624 &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
41625 &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
41626 &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
41627 &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
41628 &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
41629 DATA (XPV(I,5,0),I=1,100)/
41630 &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
41631 &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
41632 &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
41633 &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
41634 &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
41635 &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
41636 &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
41637 &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
41638 &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
41639 &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
41640 &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
41641 &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
41642 &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
41643 &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
41644 &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
41645 &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
41646 &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
41647 DATA (XPV(I,5,1),I=1,100)/
41648 &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
41649 &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
41650 &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
41651 &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
41652 &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
41653 &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
41654 &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
41655 &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
41656 &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
41657 &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
41658 &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
41659 &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
41660 &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
41661 &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
41662 &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
41663 &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
41664 &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
41665 DATA (XPV(I,5,2),I=1,100)/
41666 &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
41667 &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
41668 &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
41669 &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
41670 &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
41671 &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
41672 &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
41673 &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
41674 &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
41675 &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
41676 &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
41677 &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
41678 &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
41679 &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
41680 &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
41681 &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
41682 &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
41683 DATA (XPV(I,5,3),I=1,100)/
41684 &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
41685 &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
41686 &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
41687 &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
41688 &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
41689 &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
41690 &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
41691 &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
41692 &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
41693 &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
41694 &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
41695 &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
41696 &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
41697 &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
41698 &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
41699 &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
41700 &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
41701 DATA (XPV(I,5,4),I=1,100)/
41702 &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
41703 &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
41704 &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
41705 &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
41706 &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
41707 &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
41708 &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
41709 &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
41710 &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
41711 &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
41712 &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
41713 &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
41714 &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
41715 &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
41716 &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
41717 &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
41718 &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
41719 DATA (XPV(I,6,0),I=1,100)/
41720 &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
41721 &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
41722 &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
41723 &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
41724 &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
41725 &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
41726 &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
41727 &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
41728 &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
41729 &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
41730 &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
41731 &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
41732 &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
41733 &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
41734 &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
41735 &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
41736 &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
41737 DATA (XPV(I,6,1),I=1,100)/
41738 &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
41739 &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
41740 &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
41741 &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
41742 &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
41743 &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
41744 &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
41745 &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
41746 &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
41747 &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
41748 &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
41749 &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
41750 &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
41751 &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
41752 &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
41753 &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
41754 &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
41755 DATA (XPV(I,6,2),I=1,100)/
41756 &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
41757 &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
41758 &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
41759 &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
41760 &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
41761 &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
41762 &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
41763 &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
41764 &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
41765 &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
41766 &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
41767 &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
41768 &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
41769 &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
41770 &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
41771 &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
41772 &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
41773 DATA (XPV(I,6,3),I=1,100)/
41774 &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
41775 &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
41776 &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
41777 &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
41778 &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
41779 &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
41780 &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
41781 &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
41782 &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
41783 &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
41784 &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
41785 &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
41786 &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
41787 &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
41788 &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
41789 &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
41790 &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
41791 DATA (XPV(I,6,4),I=1,100)/
41792 &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
41793 &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
41794 &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
41795 &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
41796 &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
41797 &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
41798 &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
41799 &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
41800 &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
41801 &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
41802 &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
41803 &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
41804 &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
41805 &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
41806 &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
41807 &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
41808 &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
41809 DATA (XPV(I,7,0),I=1,100)/
41810 &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
41811 &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
41812 &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
41813 &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
41814 &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
41815 &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
41816 &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
41817 &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
41818 &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
41819 &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
41820 &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
41821 &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
41822 &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
41823 &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
41824 &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
41825 &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
41826 &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
41827 DATA (XPV(I,7,1),I=1,100)/
41828 &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
41829 &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
41830 &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
41831 &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
41832 &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
41833 &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
41834 &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
41835 &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
41836 &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
41837 &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
41838 &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
41839 &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
41840 &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
41841 &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
41842 &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
41843 &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
41844 &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
41845 DATA (XPV(I,7,2),I=1,100)/
41846 &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
41847 &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
41848 &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
41849 &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
41850 &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
41851 &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
41852 &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
41853 &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
41854 &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
41855 &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
41856 &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
41857 &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
41858 &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
41859 &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
41860 &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
41861 &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
41862 &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
41863 DATA (XPV(I,7,3),I=1,100)/
41864 &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
41865 &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
41866 &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
41867 &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
41868 &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
41869 &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
41870 &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
41871 &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
41872 &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
41873 &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
41874 &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
41875 &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
41876 &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
41877 &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
41878 &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
41879 &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
41880 &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
41881 DATA (XPV(I,7,4),I=1,100)/
41882 &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
41883 &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
41884 &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
41885 &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
41886 &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
41887 &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
41888 &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
41889 &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
41890 &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
41891 &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
41892 &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
41893 &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
41894 &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
41895 &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
41896 &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
41897 &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
41898 &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
41899
41900C..fetching pdfs
41901 DO 5 IP=-6,6
41902 XPDF(IP)=ZEROD
41903 5 CONTINUE
41904 DO 2 I=1,IX
41905 ENT(I)=LOG10(XT(I))
41906 2 CONTINUE
41907 NA(1)=IX
41908 NA(2)=IQ
41909 DO 3 I=1,IQ
41910 ENT(IX+I)=LOG10(Q2T(I))
41911 3 CONTINUE
41912 ARG(1)=LOG10(X)
41913 ARG(2)=LOG10(Q2)
41914C..various flavours (u-->2,d-->1)
41915 XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
41916 XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
41917 XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
41918 XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
41919 XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
41920 DO 21 JF=1,4
41921 XPDF(-JF)=XPDF(JF)
41922 21 CONTINUE
41923
41924 END
41925
41926CDECK ID>, PHO_DBFINT
41927 DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
41928C***********************************************************************
41929C
41930C routine based on CERN library E104
41931C
41932C multi-dimensional interpolation routine, needed for PHOJET
41933C internal cross section tables and several PDF sets (GRV98 and AGL)
41934C
41935C changed to avoid recursive function calls (R.Engel, 09/98)
41936C
41937C***********************************************************************
41938 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41939 SAVE
41940
41941 INTEGER NA(NARG), INDEX(32)
41942 DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
41943
41944 DATA ZEROD/0.D0/
41945 DATA ONED/1.D0/
41946
41947 DBFINT = ZEROD
41948 PHO_DBFINT = ZEROD
41949 IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
41950
41951 LMAX = 0
41952 ISTEP = 1
41953 KNOTS = 1
41954 INDEX(1) = 1
41955 WEIGHT(1) = ONED
41956 DO 100 N = 1, NARG
41957 X = ARG(N)
41958 NDIM = NA(N)
41959 LOCA = LMAX
41960 LMIN = LMAX + 1
41961 LMAX = LMAX + NDIM
41962 IF(NDIM .GT. 2) GOTO 10
41963 IF(NDIM .EQ. 1) GOTO 100
41964 H = X - ENT(LMIN)
41965 IF(H .EQ. ZEROD) GOTO 90
41966 ISHIFT = ISTEP
41967 IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
41968 ISHIFT = 0
41969 ETA = H / (ENT(LMIN+1) - ENT(LMIN))
41970 GOTO 30
41971 10 LOCB = LMAX + 1
41972 11 LOCC = (LOCA+LOCB) / 2
41973 IF(X-ENT(LOCC)) 12, 20, 13
41974 12 LOCB = LOCC
41975 GOTO 14
41976 13 LOCA = LOCC
41977 14 IF(LOCB-LOCA .GT. 1) GOTO 11
41978 LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
41979 ISHIFT = (LOCA - LMIN) * ISTEP
41980 ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
41981 GOTO 30
41982 20 ISHIFT = (LOCC - LMIN) * ISTEP
41983 21 DO 22 K = 1, KNOTS
41984 INDEX(K) = INDEX(K) + ISHIFT
41985 22 CONTINUE
41986 GOTO 90
41987 30 DO 31 K = 1, KNOTS
41988 INDEX(K) = INDEX(K) + ISHIFT
41989 INDEX(K+KNOTS) = INDEX(K) + ISTEP
41990 WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
41991 WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
41992 31 CONTINUE
41993 KNOTS = 2*KNOTS
41994 90 ISTEP = ISTEP * NDIM
41995 100 CONTINUE
41996 DO 200 K = 1, KNOTS
41997 I = INDEX(K)
41998 DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
41999 200 CONTINUE
42000
42001 PHO_DBFINT = DBFINT
42002
42003 END
42004
42005CDECK ID>, PHVAL
42006 SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
42007C**********************************************************************
42008C
42009C dummy subroutine, remove to link PHOLIB
42010C
42011C**********************************************************************
42012 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42013 DIMENSION PD(-6:6)
42014 END