]> git.uio.no Git - u/mrichter/AliRoot.git/blame - DPMJET/phojet1.12-35c4.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fix to access the efficiency map file
[u/mrichter/AliRoot.git] / DPMJET / phojet1.12-35c4.f
CommitLineData
7b076c76 1C***********************************************************************
2C
3C
4C
5C PHOJET version 1.12
6C -------------------
7C
8C
9C ($Revision: 1.12.1.35 $, $Date: 2000/06/25 21:59:19 $)
10C
11C
12C Authors: Ralph Engel
13C (ralph.engel@fzk.de)
14C
15C Johannes Ranft
16C (johannes.ranft@cern.ch)
17C
18C Stefan Roesler
19C (Stefan.Roesler@cern.ch)
20C
21C
22C For the latest version and documentation check
23C http://www-ik.fzk.de/~engel/phojet.html
24C
25C
26C Bug reports, questions, complaints are welcome
27C (please send a mail to ralph.engel@fzk.de).
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
397*$ CREATE PHO_INIT.FOR
398*COPY PHO_INIT
399CDECK ID>, PHO_INIT
400 SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
401C***********************************************************************
402C
403C main subroutine to configure and manage PHOJET calculations
404C
405C input: LINP input unit to read from
406C -1 to skip reading of input file
407C LOUT output unit to write to
408C
409C output: IREJ 0 success
410C 1 failure
411C
412C***********************************************************************
413 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
414 SAVE
415
416C input/output channels
417 INTEGER LI,LO
418 COMMON /POINOU/ LI,LO
419C event debugging information
420 INTEGER NMAXD
421 PARAMETER (NMAXD=100)
422 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
423 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
424 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
425 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
426C model switches and parameters
427 CHARACTER*8 MDLNA
428 INTEGER ISWMDL,IPAMDL
429 DOUBLE PRECISION PARMDL
430 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
431C general process information
432 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
433 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
434
435C global event kinematics and particle IDs
436 INTEGER IFPAP,IFPAB
437 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
438 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
439C nucleon-nucleus / nucleus-nucleus interface to DPMJET
440 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
441 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
442 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
443 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
444C integration precision for hard cross sections (obsolete)
445 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
446 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
447C some hadron information, will be deleted in future versions
448 INTEGER NFS
449 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
450 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
451C obsolete cut-off information
452 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
453 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
454C photon flux kinematics and cuts
455 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
456 & YMIN1,YMAX1,YMIN2,YMAX2,
457 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
458 & THMIN1,THMAX1,THMIN2,THMAX2
459 INTEGER ITAG1,ITAG2
460 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
461 & YMIN1,YMAX1,YMIN2,YMAX2,
462 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
463 & THMIN1,THMAX1,THMIN2,THMAX2,
464 & ITAG1,ITAG2
465C cut probability distribution
466 INTEGER IEETA1,IIMAX,KKMAX
467 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
468 INTEGER IEEMAX,IMAX,KMAX
469 REAL PROB
470 DOUBLE PRECISION EPTAB
471 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
472 & IEEMAX,IMAX,KMAX
473C event weights and generated cross section
474 INTEGER IPOWGC,ISWCUT,IVWGHT
475 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
476 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
477 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
478C names of hard scattering processes
479 INTEGER Max_pro_1
480 PARAMETER ( Max_pro_1 = 16 )
481 CHARACTER*18 PROC
482 COMMON /POHPRO/ PROC(0:Max_pro_1)
483C hard cross sections and MC selection weights
484 INTEGER Max_pro_2
485 PARAMETER ( Max_pro_2 = 16 )
486 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
487 & MH_acc_1,MH_acc_2
488 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
489 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
490 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
491 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
492 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
493 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
494
495 INTEGER MSTU,MSTJ
496 DOUBLE PRECISION PARU,PARJ
497 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
498
499 INTEGER KCHG
500 DOUBLE PRECISION PMAS,PARF,VCKM
501 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
502
503 INTEGER MDCY,MDME,KFDP
504 DOUBLE PRECISION BRAT
a374771e 505 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 506
507 INTEGER PYCOMP
508
509 DIMENSION ITMP(0:11)
510 CHARACTER*10 CNAME
511 CHARACTER*70 NUMBER,FILENA
512
513 14 FORMAT(A10,A69)
514 15 FORMAT(A12)
515
516C define input/output units
517 IF(LINP.GE.0) THEN
518 LI = LINP
519 ELSE
520 LI = 5
521 ENDIF
522 LO = LOUT
523
524 IREJ = 0
525
526 WRITE(LO,*)
527 WRITE(LO,*) ' ==================================================='
528 WRITE(LO,*) ' '
529 WRITE(LO,*) ' ---- PHOJET version 1.12 ---- '
530 WRITE(LO,*) ' '
531 WRITE(LO,*) ' ==================================================='
532 WRITE(LO,*) ' Authors: Ralph Engel (FZ Karlsruhe)'
533 WRITE(LO,*) ' Johannes Ranft (Siegen Univ.)'
534 WRITE(LO,*) ' Stefan Roesler (CERN)'
535 WRITE(LO,*) ' ---------------------------------------------------'
536 WRITE(LO,*) ' Manual, updates, and further information:'
537 WRITE(LO,*) ' http://www-ik.fzk.de/~engel/phojet.html'
538 WRITE(LO,*) ' ---------------------------------------------------'
539 WRITE(LO,*) ' please send suggestions / bug reports etc. to:'
540 WRITE(LO,*) ' ralph.engel@fzk.de'
541 WRITE(LO,*) ' ==================================================='
542 WRITE(LO,*) ' $Date: 2000/06/25 21:59:19 $'
543 WRITE(LO,*) ' $Revision: 1.12.1.35 $'
544
545 WRITE(LO,*) ' (code version with interface to PYTHIA 6.x)'
546
547 WRITE(LO,*) ' (code version for usage in DPMJET 3.x)'
548
549 WRITE(LO,*) ' ==================================================='
550 WRITE(LO,*)
551
552C standard initializations
553 CALL PHO_DATINI
554 CALL PHO_PARDAT
555 DUM = PHO_PMASS(0,-1)
556
557C initialize standard PDFs
558C proton
559 CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
560 CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
561C neutron
562 CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
563 CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
564C photon
565 CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
566C pomeron
567 CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
568C pions
569 CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
570 CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
571 CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
572C kaons
573 CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
574 CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
575 CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
576 CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
577
578C nothing to be done
579 IF(LINP.LT.0) RETURN
580
581C main loop to read input cards
582 1200 CONTINUE
583 READ(LINP,14,END=1300) CNAME,NUMBER
584 IF(CNAME.EQ.'ENDINPUT ') THEN
585 GOTO 1300
586 ELSE IF(CNAME.EQ.'STOP ') THEN
587 WRITE(LO,*) 'STOP'
588 STOP
589 ELSE IF(CNAME.EQ.'COMMENT ') THEN
590 WRITE(LO,'(1X,A10,A69)') 'COMMENT ',NUMBER
591 ELSE IF(CNAME(1:1).EQ.'*') THEN
592 WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
593 ELSE IF(CNAME.EQ.'PTCUT ') THEN
594 READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
595 WRITE(LO,*) 'PTCUT ',PARMDL(36),PARMDL(37),
596 & PARMDL(38),PARMDL(39)
597 ELSE IF(CNAME.EQ.'PROCESS ') THEN
598 READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
599 WRITE(LO,*) 'PROCESS ',(IPRON(KK,1),KK=1,8)
600 ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
601 READ(NUMBER,*) (ITMP(KK),KK=0,11)
602 WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
603 DO 112 KK=1,8
604 IPRON(KK,ITMP(0)) = ITMP(KK)
605 112 CONTINUE
606 ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
607 READ(NUMBER,*) IMPRO,IP,ION
608 WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
609 MH_pro_on(IMPRO,IP) = ION
610 ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
611 READ(NUMBER,*) IDPDG,PVIR
612 IHFLS(1) = 1
613 XPSUB = 1.D0
614 CALL PHO_SETPAR(1,IDPDG,0,PVIR)
615 WRITE(LO,*) 'PARTICLE1 ',IDPDG,PVIR
616 ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
617 READ(NUMBER,*) IDPDG,PVIR
618 IHFLS(2) = 1
619 XTSUB = 1.D0
620 CALL PHO_SETPAR(2,IDPDG,0,PVIR)
621 WRITE(LO,*) 'PARTICLE2 ',IDPDG,PVIR
622 ELSE IF(CNAME.EQ.'REMNANT1 ') THEN
623 READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
624 IHFLS(1) = IVAL
625 IHFLD(1,1) = IFL1
626 IHFLD(1,2) = IFL2
627 XPSUB = XSUB
628 PVIR = 0.D0
629 CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
630 WRITE(LO,*) 'REMNANT1 ',IDPDG,IFL1,IFL2,IVAL,XSUB
631 ELSE IF(CNAME.EQ.'REMNANT2 ') THEN
632 READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
633 IHFLS(2) = IVAL
634 IHFLD(2,1) = IFL1
635 IHFLD(2,2) = IFL2
636 XTSUB = XSUB
637 PVIR = 0.D0
638 CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
639 WRITE(LO,*) 'REMNANT2 ',IDPDG,IFL1,IFL2,IVAL,XSUB
640 ELSE IF(CNAME.EQ.'PDF ') THEN
641 READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
642 WRITE(LO,*) 'PDF ',IDPDG,IPAR,ISET,IEXT
643 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
644 ELSE IF(CNAME.EQ.'SETMODEL ') THEN
645 READ(NUMBER,*) I,IVAL
646 WRITE(LO,*) 'SETMODEL ',I,IVAL
647 CALL PHO_SETMDL(I,IVAL,1)
648 ELSE IF(CNAME.EQ.'SETPARAM ') THEN
649 READ(NUMBER,*) I,PARNEW
650 WRITE(LO,*) 'SETPARAM ',I,PARNEW
651 PARMDL(I) = PARNEW
652 ELSE IF(CNAME.EQ.'DEBUG ') THEN
653 READ(NUMBER,*) IDEBF,IDEBN,IDLEV
654 WRITE(LO,*) 'DEBUG ',IDEBF,IDEBN,IDLEV
655 CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
656 ELSE IF(CNAME.EQ.'TRACE ') THEN
657 READ(NUMBER,*) IDEBF,IDLEV
658 WRITE(LO,*) 'TRACE ',IDEBF,IDLEV
659 IDEB(IDEBF) = IDLEV
660 ELSE IF(CNAME.EQ.'SETICUT ') THEN
661 READ(NUMBER,*) I,ICUT
662 WRITE(LO,*) 'SETICUT ',I,ICUT
663 ISWCUT(I) = ICUT
664 ELSE IF(CNAME.EQ.'SETFCUT ') THEN
665 READ(NUMBER,*) I,PARNEW
666 WRITE(LO,*) 'SETFCUT ',I,PARNEW
667 HSWCUT(I) = PARNEW
668 ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
669 READ(NUMBER,*) I,IVAL
670 WRITE(LO,*) 'LUND-MSTU ',I,IVAL
671 MSTU(I) = IVAL
672 ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
673 READ(NUMBER,*) I,IVAL
674 WRITE(LO,*) 'LUND-MSTJ ',I,IVAL
675 MSTJ(I) = IVAL
676 ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
677 READ(NUMBER,*) I,EE
678 WRITE(LO,*) 'LUND-PARJ ',I,EE
679 PARJ(I) = REAL(EE)
680 ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
681 READ(NUMBER,*) I,EE
682 WRITE(LO,*) 'LUND-PARU ',I,EE
683 PARU(I) = REAL(EE)
684 ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
685 READ(NUMBER,*) ID,ION
686 WRITE(LO,*) 'LUND-DECAY ',ID,ION
687
688 KC=PYCOMP(ID)
689
690 MDCY(KC,1) = ION
691 ELSE IF(CNAME.EQ.'PSOFTMIN ') THEN
692 READ(NUMBER,*) PSOMIN
693 WRITE(LO,*) 'PSOFTMIN ',PSOMIN
694 ELSE IF(CNAME.EQ.'INTPREC ') THEN
695 READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
696 WRITE(LO,*) 'INTPREC ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
697
698C PDF test utility
699 ELSE IF(CNAME.EQ.'PDFTEST ') THEN
700 READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
701 PVIRT2 = ABS(PVIRT2)
702 WRITE(LO,*) 'PDFTEST ',IDPDG,' ',SCALE2,' ',PVIRT2
703 CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
704
705C mass cut on gamma-gamma or gamma-hadron system
706 ELSE IF(CNAME.EQ.'ECMS-CUT ') THEN
707 READ(NUMBER,*) ECMIN,ECMAX
708 WRITE(LO,*) 'ECMS-CUT ',ECMIN,ECMAX
709
710C beam lepton (anti-)tagging system
711 ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
712 READ(NUMBER,*) ITAG1,ITAG2
713 WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
714 ELSE IF(CNAME.EQ.'E-TAG1 ') THEN
715 READ(NUMBER,*)
716 & EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
717 WRITE(LO,*) 'E-TAG1 ',EEMIN1,YMIN1,YMAX1,
718 & Q2MIN1,Q2MAX1,THMIN1,THMAX1
719 ELSE IF(CNAME.EQ.'E-TAG2 ') THEN
720 READ(NUMBER,*)
721 & EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
722 WRITE(LO,*) 'E-TAG2 ',EEMIN2,YMIN2,YMAX2,
723 & Q2MIN2,Q2MAX2,THMIN2,THMAX2
724
725C sampling of gamma-p events in ep (HERA)
726 ELSE IF( (CNAME.EQ.'WW-HERA ')
727 & .OR.(CNAME.EQ.'GP-HERA ')) THEN
728 READ(NUMBER,*) EE1,EE2,NEV
729 WRITE(LO,*) 'GP-HERA ',EE1,EE2,NEV
730 IF(YMAX2.LT.0.D0) THEN
731 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
732 ELSE
733 CALL PHO_GPHERA(NEV,EE1,EE2)
734 KEVENT = 0
735 ENDIF
736
737C sampling of gamma-gamma events in e+e- (LEP)
738 ELSE IF( (CNAME.EQ.'GG-EPEM ')
739 & .OR.(CNAME.EQ.'WW-EPEM ')) THEN
740 READ(NUMBER,*) EE1,EE2,NEV
741 WRITE(LO,*) 'GG-EPEM ',EE1,EE2,NEV
742 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
743 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
744 ELSE
745 CALL PHO_GGEPEM(-1,EE1,EE2)
746 CALL PHO_GGEPEM(NEV,EE1,EE2)
747 CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
748 KEVENT = 0
749 ENDIF
750
751C sampling of gamma-gamma in heavy-ion collisions
752 ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
753 READ(NUMBER,*) EE,NA,NZ,NEV
754 WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
755 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
756 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
757 ELSE
758 CALL PHO_GGHIOF(NEV,EE,NA,NZ)
759 KEVENT = 0
760 ENDIF
761 ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
762 READ(NUMBER,*) EE,NA,NZ,NEV
763 WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
764 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
765 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
766 ELSE
767 CALL PHO_GGHIOG(NEV,EE,NA,NZ)
768 KEVENT = 0
769 ENDIF
770
771C sampling of gamma-hadron events in heavy ion collisions
772 ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
773 READ(NUMBER,*) EE,NA,NZ,NEV
774 WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
775 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
776 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
777 ELSE
778 CALL PHO_GHHIOF(NEV,EE,NA,NZ)
779 KEVENT = 0
780 ENDIF
781
782C sampling of hadron-gamma events in hadron - heavy ion collisions
783 ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
784 READ(NUMBER,*) EP,EE,NA,NZ,NEV
785 WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
786 IF(YMAX2.LT.0.D0) THEN
787 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
788 ELSE
789 CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
790 KEVENT = 0
791 ENDIF
792
793C sampling of photoproduction events e+e-, backscattered laser
794 ELSE IF(CNAME.EQ.'BLASER ') THEN
795 READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
796 WRITE(LO,*) 'BLASER ',EE1,EE2,
797 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
798 CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
799 KEVENT = 0
800
801C sampling of photoproduction events beamstrahlung
802 ELSE IF(CNAME.EQ.'BEAMST ') THEN
803 READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
804 WRITE(LO,*) 'BEAMST ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
805 IF(YMAX1.LT.0.D0) THEN
806 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
807 ELSE
808 CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
809 KEVENT = 0
810 ENDIF
811
812C fixed-energy events in LAB system of particle 2
813 ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
814 READ(NUMBER,*) PLAB,NEV
815 WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
816 CALL PHO_FIXLAB(PLAB,NEV)
817 KEVENT = 0
818
819C fixed-energy events in CM system
820 ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
821 READ(NUMBER,*) ECM,NEV
822 WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
823 PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
824 PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
825 CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
826 E1 = EE
827 E2 = ECM-EE
828 THETA = 0.D0
829 PHI = 0.D0
830 CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
831 KEVENT = 0
832
833C fixed-energy events for collider setup with crossing angle
834 ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
835 READ(NUMBER,*) E1,E2,THETA,PHI,NEV
836 WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
837 CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
838 KEVENT = 0
839
840C unknown data card
841 ELSE
842 WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
843 ENDIF
844
845 GOTO 1200
846 1300 CONTINUE
847 WRITE(LO,*) ' RETURN'
848
849 END
850
851*$ CREATE PHO_SETMDL.FOR
852*COPY PHO_SETMDL
853CDECK ID>, PHO_SETMDL
854 SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
855C**********************************************************************
856C
857C set model switches
858C
859C input: INDX model parameter number
860C (positive: ISWMDL, negative: IPAMDL)
861C IVAL new value
862C IMODE -1 print value of parameter INDX
863C 1 set new value
864C -2 print current settings
865C
866C**********************************************************************
867 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
868 SAVE
869
870C input/output channels
871 INTEGER LI,LO
872 COMMON /POINOU/ LI,LO
873C model switches and parameters
874 CHARACTER*8 MDLNA
875 INTEGER ISWMDL,IPAMDL
876 DOUBLE PRECISION PARMDL
877 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
878
879 IF(IMODE.EQ.-2) THEN
880 WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
881 & '----------------------------'
882 DO 100 I=1,48,3
883 IF(ISWMDL(I).EQ.-9999) GOTO 200
884 IF(ISWMDL(I+1).EQ.-9999) THEN
885 WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
886 GOTO 200
887 ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
888 WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
889 & I+1,':',MDLNA(I+1),ISWMDL(I+1)
890 GOTO 200
891 ELSE
892 WRITE(LO,'(3(5X,I3,A1,A,I6))')
893 & (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
894 ENDIF
895 100 CONTINUE
896 200 CONTINUE
897 ELSE IF(IMODE.EQ.-1) THEN
898 WRITE(LO,'(1X,A,1X,A,I6)')
899 & 'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
900 ELSE IF(IMODE.EQ.1) THEN
901 IF(INDX.GT.0) THEN
902 IF(ISWMDL(INDX).NE.IVAL) THEN
903 WRITE(LO,'(1X,A,I4,1X,A,2I6)')
904 & 'PHO_SETMDL:ISWMDL(OLD/NEW):',
905 & INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
906 ISWMDL(INDX) = IVAL
907 ENDIF
908 ELSE IF(INDX.LT.0) THEN
909 IF(IPAMDL(-INDX).NE.IVAL) THEN
910 WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
911 & -INDX,IPAMDL(-INDX),IVAL
912 IPAMDL(-INDX) = IVAL
913 ENDIF
914 ENDIF
915 ELSE
916 WRITE(LO,'(/1X,A,I6)')
917 & 'PHO_SETMDL:ERROR: unsupported mode',IMODE
918 ENDIF
919 END
920
921*$ CREATE PHO_DATINI.FOR
922*COPY PHO_DATINI
923CDECK ID>, PHO_DATINI
924 SUBROUTINE PHO_DATINI
925C*********************************************************************
926C
927C initialization of variables and switches
928C
929C*********************************************************************
930 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
931 SAVE
932
933C input/output channels
934 INTEGER LI,LO
935 COMMON /POINOU/ LI,LO
936C some constants
937 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
938 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
939 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
940C event debugging information
941 INTEGER NMAXD
942 PARAMETER (NMAXD=100)
943 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
944 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
945 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
946 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
947C event weights and generated cross section
948 INTEGER IPOWGC,ISWCUT,IVWGHT
949 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
950 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
951 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
952C scale parameters for parton model calculations
953 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
954 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
955 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
956 & NQQAL,NQQALI,NQQALF,NQQPD
957C integration precision for hard cross sections (obsolete)
958 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
959 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
960C hard scattering parameters used for most recent hard interaction
961 INTEGER NFbeta,NF
962 DOUBLE PRECISION ALQCD2,BQCD
963 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
964C cut probability distribution
965 INTEGER IEETA1,IIMAX,KKMAX
966 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
967 INTEGER IEEMAX,IMAX,KMAX
968 REAL PROB
969 DOUBLE PRECISION EPTAB
970 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
971 & IEEMAX,IMAX,KMAX
972C gamma-lepton or gamma-hadron vertex information
973 INTEGER IGHEL,IDPSRC,IDBSRC
974 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
975 & RADSRC,AMSRC,GAMSRC
976 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
977 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
978 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
979C photon flux kinematics and cuts
980 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
981 & YMIN1,YMAX1,YMIN2,YMAX2,
982 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
983 & THMIN1,THMAX1,THMIN2,THMAX2
984 INTEGER ITAG1,ITAG2
985 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
986 & YMIN1,YMAX1,YMIN2,YMAX2,
987 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
988 & THMIN1,THMAX1,THMIN2,THMAX2,
989 & ITAG1,ITAG2
990C obsolete cut-off information
991 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
992 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
993C global event kinematics and particle IDs
994 INTEGER IFPAP,IFPAB
995 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
996 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
997C nucleon-nucleus / nucleus-nucleus interface to DPMJET
998 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
999 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
1000 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
1001 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
1002C some hadron information, will be deleted in future versions
1003 INTEGER NFS
1004 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
1005 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
1006C model switches and parameters
1007 CHARACTER*8 MDLNA
1008 INTEGER ISWMDL,IPAMDL
1009 DOUBLE PRECISION PARMDL
1010 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
1011C general process information
1012 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
1013 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
1014C parameters of the "simple" Vector Dominance Model
1015 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
1016 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
1017C parameters for DGLAP backward evolution in ISR
1018 INTEGER NFSISR
1019 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
1020 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
1021C particles created by initial state evolution
1022 INTEGER MXISR1,MXISR2
1023 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
1024 INTEGER IFLISR,IPOISR,IMXISR
1025 DOUBLE PRECISION PHISR
1026 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
1027 & IPOISR(2,2,MXISR2),IMXISR(2)
1028C names of hard scattering processes
1029 INTEGER Max_pro_1
1030 PARAMETER ( Max_pro_1 = 16 )
1031 CHARACTER*18 PROC
1032 COMMON /POHPRO/ PROC(0:Max_pro_1)
1033C hard cross sections and MC selection weights
1034 INTEGER Max_pro_2
1035 PARAMETER ( Max_pro_2 = 16 )
1036 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
1037 & MH_acc_1,MH_acc_2
1038 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
1039 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
1040 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
1041 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
1042 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
1043 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
1044C interpolation tables for hard cross section and MC selection weights
1045 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
1046 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
1047 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
1048 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
1049 & HQ2a_tab,HQ2b_tab,HEcm_tab
1050 COMMON /POHTAB/
1051 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1052 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1053 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1054 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1055 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
1056 & HEcm_tab(1:Max_tab_E,0:4),
1057 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
1058
1059C initialize /POCONS/
1060 PI = ATAN(1.D0)*4.D0
1061 PI2 = 2.D0*PI
1062 PI4 = 2.D0*PI2
1063C GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
1064 GEV2MB = 0.389365D0
1065C precalculate quark charges
1066 do i=1,6
1067 Q_ch(i) = dble(2-3*mod(i,2))/3.D0
1068 Q_ch(-i) = -Q_ch(i)
1069
1070 Q_ch2(i) = Q_ch(i)**2
1071 Q_ch2(-i) = Q_ch2(i)
1072
1073 Q_ch4(i) = Q_ch2(i)**2
1074 Q_ch4(-i) = Q_ch4(i)
1075 enddo
1076 Q_ch(0) = 0.D0
1077 Q_ch2(0) = 0.D0
1078 Q_ch4(0) = 0.D0
1079
1080C initialize /GLOCMS/
1081 ECM = 50.D0
1082 PMASS(1) = 0.D0
1083 PVIRT(1) = 0.D0
1084 PMASS(2) = 0.D0
1085 PVIRT(2) = 0.D0
1086 IFPAP(1) = 22
1087 IFPAP(2) = 22
1088C initialize /HADVAL/
1089 IHFLD(1,1) = 0
1090 IHFLD(1,2) = 0
1091 IHFLD(2,1) = 0
1092 IHFLD(2,2) = 0
1093 IHFLS(1) = 1
1094 IHFLS(2) = 1
1095C initialize /MODELS/
1096 ISWMDL(1) = 3
1097 MDLNA(1) = 'AMPL MOD'
1098 ISWMDL(2) = 1
1099 MDLNA(2) = 'MIN-BIAS'
1100 ISWMDL(3) = 1
1101 MDLNA(3) = 'PTS DISH'
1102 ISWMDL(4) = 1
1103 MDLNA(4) = 'PTS DISP'
1104 ISWMDL(5) = 2
1105 MDLNA(5) = 'PTS ASSI'
1106 ISWMDL(6) = 3
1107 MDLNA(6) = 'HADRONIZ'
1108 ISWMDL(7) = 2
1109 MDLNA(7) = 'MASS COR'
1110 ISWMDL(8) = 3
1111 MDLNA(8) = 'PAR SHOW'
1112 ISWMDL(9) = 0
1113 MDLNA(9) = 'GLU SPLI'
1114 ISWMDL(10) = 2
1115 MDLNA(10) = 'VIRT PHO'
1116 ISWMDL(11) = 0
1117 MDLNA(11) = 'LARGE NC'
1118 ISWMDL(12) = 0
1119 MDLNA(12) = 'LIPA POM'
1120 ISWMDL(13) = 1
1121 MDLNA(13) = 'QELAS VM'
1122 ISWMDL(14) = 2
1123 MDLNA(14) = 'ENHA GRA'
1124 ISWMDL(15) = 4
1125 MDLNA(15) = 'MULT SCA'
1126 ISWMDL(16) = 4
1127 MDLNA(16) = 'MULT DIF'
1128 ISWMDL(17) = 4
1129 MDLNA(17) = 'MULT CDF'
1130 ISWMDL(18) = 0
1131 MDLNA(18) = 'BALAN PT'
1132 ISWMDL(19) = 1
1133 MDLNA(19) = 'POMV FLA'
1134 ISWMDL(20) = 0
1135 MDLNA(20) = 'SEA FLA'
1136 ISWMDL(21) = 2
1137 MDLNA(21) = 'SPIN DEC'
1138 ISWMDL(22) = 1
1139 MDLNA(22) = 'DIF.MASS'
1140 ISWMDL(23) = 1
1141 MDLNA(23) = 'DIFF RES'
1142 ISWMDL(24) = 0
1143 MDLNA(24) = 'PTS HPOM'
1144 ISWMDL(25) = 0
1145 MDLNA(25) = 'POM CORR'
1146 ISWMDL(26) = 1
1147 MDLNA(26) = 'OVERLAP '
1148 ISWMDL(27) = 0
1149 MDLNA(27) = 'MUL R/AN'
1150 ISWMDL(28) = 1
1151 MDLNA(28) = 'SUR PROB'
1152 ISWMDL(29) = 1
1153 MDLNA(29) = 'PRIMO KT'
1154 ISWMDL(30) = 0
1155 MDLNA(30) = 'DIFF. CS'
1156 ISWMDL(31) = -9999
1157C mass-independent sea flavour ratios (for low-mass strings)
1158 PARMDL(1) = 0.425D0
1159 PARMDL(2) = 0.425D0
1160 PARMDL(3) = 0.15D0
1161 PARMDL(4) = 0.D0
1162 PARMDL(5) = 0.D0
1163 PARMDL(6) = 0.D0
1164C suppression by energy momentum conservation
1165 PARMDL(8) = 9.D0
1166 PARMDL(9) = 7.D0
1167C VDM factors
1168 PARMDL(10) = 0.866D0
1169 PARMDL(11) = 0.288D0
1170 PARMDL(12) = 0.288D0
1171 PARMDL(13) = 0.288D0
1172 PARMDL(14) = 0.866D0
1173 PARMDL(15) = 0.288D0
1174 PARMDL(16) = 0.288D0
1175 PARMDL(17) = 0.288D0
1176 PARMDL(18) = 0.D0
1177C lower energy limit for initialization
1178 PARMDL(19) = 5.D0
1179C soft pt for hard scattering remnants
1180 PARMDL(20) = 5.D0
1181C low energy beta of soft pt distribution 1
1182 PARMDL(21) = 4.5D0
1183C high energy beta of soft pt distribution 1
1184 PARMDL(22) = 3.0D0
1185C low energy beta of soft pt distribution 0
1186 PARMDL(23) = 2.5D0
1187C high energy beta of soft pt distribution 0
1188 PARMDL(24) = 0.4D0
1189C effective quark mass in photon wave function
1190 PARMDL(25) = 0.2D0
1191C normalization of unevolved Pomeron PDFs
1192 PARMDL(26) = 0.3D0
1193C effective VDM parameters for Q**2 dependence of cross section
1194 PARMDL(27) = 0.65D0
1195 PARMDL(28) = 0.08D0
1196 PARMDL(29) = 0.05D0
1197 PARMDL(30) = 0.22D0
1198 PARMDL(31) = 0.589824D0
1199 PARMDL(32) = 0.609961D0
1200 PARMDL(33) = 1.038361D0
1201 PARMDL(34) = 1.96D0
1202C Q**2 suppression of multiple interactions
1203 PARMDL(35) = 0.59D0
1204C pt cutoff defaults
1205 PARMDL(36) = 2.5D0
1206 PARMDL(37) = 2.5D0
1207 PARMDL(38) = 2.5D0
1208 PARMDL(39) = 2.5D0
1209C enhancement factor for diffractive cross sections
1210 PARMDL(40) = 1.D0
1211 PARMDL(41) = 1.D0
1212 PARMDL(42) = 1.D0
1213C mass in soft pt distribution
1214 PARMDL(43) = 0.D0
1215C maximum of x allowed for leading particle
1216 PARMDL(44) = 0.9D0
1217C max. mass sampled in diffraction
1218 PARMDL(45) = sqrt(0.4D0)
1219C mass threshold in diffraction (2pi mass)
1220 PARMDL(46) = 0.3D0
1221C regularization of slope parameter in diffraction
1222 PARMDL(47) = 4.D0
1223C renormalized intercept for enhanced graphs
1224 PARMDL(48) = 1.08D0
1225C coherence constraint for diff. cross sections
1226 PARMDL(49) = sqrt(0.05D0)
1227C exponents of x distributions
1228C baryon
1229 PARMDL(50) = 1.5D0
1230 PARMDL(51) = -0.5D0
1231 PARMDL(52) = -0.99D0
1232 PARMDL(53) = -0.99D0
1233C meson (non-strangeness part)
1234 PARMDL(54) = -0.5D0
1235 PARMDL(55) = -0.5D0
1236 PARMDL(56) = -0.99D0
1237 PARMDL(57) = -0.99D0
1238C meson (strangeness part)
1239 PARMDL(58) = -0.2D0
1240 PARMDL(59) = -0.2D0
1241 PARMDL(60) = -0.99D0
1242 PARMDL(61) = -0.99D0
1243C particle remnant (no valence quarks)
1244 PARMDL(62) = -0.5D0
1245 PARMDL(63) = -0.5D0
1246 PARMDL(64) = -0.99D0
1247 PARMDL(65) = -0.99D0
1248C ratio beetween triple-pomeron/reggeon couplings grrp/gppp
1249 PARMDL(66) = 10.D0
1250C ratio beetween triple-pomeron/reggeon couplings gppr/gppp
1251 PARMDL(67) = 10.D0
1252C min. abs(t) in diffraction
1253 PARMDL(68) = 0.D0
1254C max. abs(t) in diffraction
1255 PARMDL(69) = 10.D0
1256C min. mass for elastic pomerons in central diffraction
1257 PARMDL(70) = 2.D0
1258C min. mass of diffractive blob in central diffraction
1259 PARMDL(71) = 2.D0
1260C min. Feynman x cut in central diffraction
1261 PARMDL(72) = 0.D0
1262C direct pomeron coupling
1263 PARMDL(74) = 0.D0
1264C relative deviation allowed for energy-momentum conservation
1265C energy-momentum relative deviation
1266 PARMDL(75) = 0.01D0
1267C transverse momentum deviation
1268 PARMDL(76) = 0.01D0
1269C couplings for unitarization in diffraction
1270C non-unitarized pomeron coupling (sqrt(mb))
1271 PARMDL(77) = 3.D0
1272C rescaling factor for pomeron PDF
1273 PARMDL(78) = 3.D0
1274C coupling probabilities
1275 PARMDL(79) = 1.D0
1276 PARMDL(80) = 0.D0
1277C scales to calculate alpha-s of matrix element
1278 PARMDL(81) = 1.D0
1279 PARMDL(82) = 1.D0
1280 PARMDL(83) = 1.D0
1281C scales to calculate alpha-s of initial state radiation
1282 PARMDL(84) = 1.D0
1283 PARMDL(85) = 1.D0
1284 PARMDL(86) = 1.D0
1285C scales to calculate alpha-s of final state radiation
1286 PARMDL(87) = 1.D0
1287 PARMDL(88) = 1.D0
1288 PARMDL(89) = 1.D0
1289C scales to calculate PDFs
1290 PARMDL(90) = 1.D0
1291 PARMDL(91) = 1.D0
1292 PARMDL(92) = 1.D0
1293C scale for ISR starting virtuality
1294 PARMDL(93) = 1.D0
1295C min. virtuality to generate time-like showers in ISR
1296 PARMDL(94) = 2.D0
1297C factor to scale the max. allowed time-like parton shower virtuality
1298 PARMDL(95) = 4.D0
1299C max. transverse momentum for primordial kt
1300 PARMDL(100) = 2.D0
1301C weight factors for pt-distribution
1302 PARMDL(101) = 2.D0
1303 PARMDL(102) = 2.D0
1304 PARMDL(103) = 4.D0
1305 PARMDL(104) = 2.D0
1306 PARMDL(105) = 6.D0
1307 PARMDL(106) = 4.D0
1308C
1309* PARMDL(110-125) reserved for hard scattering
1310C currently chosen scales for hard scattering
1311 DO 10 I=1,16
1312 PARMDL(109+I) = 0.D0
1313 10 CONTINUE
1314C virtuality cutoff in initial state evolution
1315 PARMDL(126) = PARMDL(36)**2
1316 PARMDL(127) = PARMDL(37)**2
1317 PARMDL(128) = PARMDL(38)**2
1318 PARMDL(129) = PARMDL(39)**2
1319C virtuality cutoff for direct contribution to photon PDF
1320 PARMDL(130) = 1.D30
1321 PARMDL(131) = 1.D30
1322 PARMDL(132) = 1.D30
1323 PARMDL(133) = 1.D30
1324C fraction of events without popcorn
1325 PARMDL(134) = -1.D0
1326C fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
1327 PARMDL(135) = 0.5D0
1328C soft color re-connection (fraction)
1329C g g final state
1330 PARMDL(140) = 1.D0/64.D0
1331C g q final state
1332 PARMDL(141) = 1.D0/24.D0
1333C q q final state
1334 PARMDL(142) = 1.D0/9.D0
1335C effective scale in Drees-Godbole like suppresion in photon PDF
1336 PARMDL(144) = 0.766D0**2
1337C QCD scales (if PDF scales are not used, 4 active flavours)
1338 PARMDL(145) = 0.2D0**2
1339 PARMDL(146) = 0.2D0**2
1340 PARMDL(147) = 0.2D0**2
1341C threshold scales for variable flavour calculation (GeV**2)
1342 PARMDL(148) = 1.5D0**2
1343 PARMDL(149) = 4.5D0**2
1344 PARMDL(150) = 175.D0**2
1345C constituent quark masses
1346 PARMDL(151) = 0.3D0
1347 PARMDL(152) = 0.3D0
1348 PARMDL(153) = 0.5D0
1349 PARMDL(154) = 1.6D0
1350 PARMDL(155) = 5.D0
1351 PARMDL(156) = 174.D0
1352C min. masses of valence quark
1353 PARMDL(157) = 0.3D0
1354C min. masses of valence diquark
1355 PARMDL(158) = 0.8D0
1356C min. mass of sea quark
1357 PARMDL(159) = 0.D0
1358C suppression of strange quarks as photon valences
1359 PARMDL(160) = 0.2D0
1360C min. masses for strings (used in PHO_SOFTXX)
1361 PARMDL(161) = 1.D0
1362 PARMDL(162) = 1.D0
1363 PARMDL(163) = 1.D0
1364 PARMDL(164) = 1.D0
1365C min. momentum fraction for soft processes
1366 PARMDL(165) = 0.3D0
1367C min. phase space for x-sampling
1368 PARMDL(166) = 0.135D0
1369C Ross-Stodolsky exponent
1370 PARMDL(170) = 4.2D0
1371C cutoff on photon-pomeron invariant mass in hadron-hadron collisions
1372 PARMDL(175) = 2.D0
1373
1374**sr
1375* extra factor multiplying difference between Goulianos and PHOJET-
1376* diff. cross sections
1377 PARMDL(200) = 0.6D0
1378**
1379
1380C complex amplitudes, eikonal functions
1381 IPAMDL(1) = 0
1382C allow for Reggeon cuts
1383 IPAMDL(2) = 1
1384C decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
1385 IPAMDL(3) = 0
1386C polarization of photon resonances (0 none, 1 trans, 2 long)
1387 IPAMDL(4) = 1
1388C pt of valence partons
1389 IPAMDL(5) = 1
1390C pt of hard scattering remnant
1391 IPAMDL(6) = 2
1392C running cutoff for hard scattering
1393 IPAMDL(7) = 1
1394C intercept used for the calculation of enhanced graphs
1395 IPAMDL(8) = 1
1396C effective slope of hard scattering amplitde
1397 IPAMDL(9) = 1
1398C mass dependence of slope parameters
1399 IPAMDL(10) = 0
1400C lepton-photon vertex 1
1401 IPAMDL(11) = 0
1402C lepton-photon vertex 2
1403 IPAMDL(12) = 0
1404C call by DPMJET
1405 IPAMDL(13) = 0
1406C method to sample x distributions
1407 IPAMDL(14) = 3
1408C energy-momentum check
1409 IPAMDL(15) = 1
1410C phase space correction for DPMJET interface
1411 IPAMDL(16) = 1
1412C fragment strings from projectile/target/central diff. separately
1413 IPAMDL(17) = 1
1414C method to construct strings for hard interactions
1415 IPAMDL(18) = 1
1416C method to construct strings for soft sea (pomeron cuts)
1417 IPAMDL(19) = 0
1418C method to construct strings in pomeron interactions
1419 IPAMDL(20) = 0
1420C soft color re-connection
1421 IPAMDL(21) = 0
1422C resummation of triple- and loop-Pomeron
1423 IPAMDL(24) = 1
1424C resummation of X iterated triple-Pomeron
1425 IPAMDL(25) = 1
1426C dimension of interpolation table for weights in hard scattering
1427 IPAMDL(30) = Max_tab_E
1428C dimension of interpolation table for pomeron cut distribution
1429 IPAMDL(31) = IEETA1
1430C number of cut soft pomerons (restriction by field dimension)
1431 IPAMDL(32) = IIMAX
1432C number of cut hard pomerons (restriction by field dimension)
1433 IPAMDL(33) = KKMAX
1434C tau pair production in direct photon-photon collisions
1435 IPAMDL(64) = 0
1436C currently chosen scales for hard scattering
1437C ATTENTION: IPAMDL(65-80) reserved for hard scattering!
1438 DO 15 I=1,16
1439 IPAMDL(64+I) = -99999
1440 15 CONTINUE
1441C scales to calculate alpha-s of matrix element
1442 IPAMDL(81) = 1
1443 IPAMDL(82) = 1
1444 IPAMDL(83) = 1
1445C scales to calculate alpha-s of initial state radiation
1446 IPAMDL(84) = 1
1447 IPAMDL(85) = 1
1448 IPAMDL(86) = 1
1449C scales to calculate alpha-s of final state radiation
1450 IPAMDL(87) = 1
1451 IPAMDL(88) = 1
1452 IPAMDL(89) = 1
1453C scales to calculate PDFs
1454 IPAMDL(90) = 1
1455 IPAMDL(91) = 1
1456 IPAMDL(92) = 1
1457C where to get the parameter sets from
1458 IPAMDL(99) = 1
1459C program PHO_ABORT for fatal errors (simulation of division by zero)
1460 IPAMDL(100) = 0
1461C initial state parton showers for all / hardest interaction(s)
1462 IPAMDL(101) = 1
1463C final state parton showers for all / hardest interaction(s)
1464 IPAMDL(102) = 1
1465C initial virtuality for ISR generation
1466 IPAMDL(109) = 1
1467C qqbar-gamma coupling in initial state showers
1468 IPAMDL(110) = 1
1469C generation of time-like showers during ISR
1470 IPAMDL(111) = 1
1471C reweighting of multiple soft contributions for virtual photons
1472 IPAMDL(114) = 1
1473C reweighting / use photon virtuality in photon PDF calculations
1474 IPAMDL(115) = 0
1475C use full QPM model incl. interference terms (direct part in gam-gam)
1476 IPAMDL(116) = 0
1477C matching sigma_tot to F2 as given by parton density at high Q2
1478 IPAMDL(117) = 1
1479C use virtuality of target in F2 calculations (two-gamma only)
1480 IPAMDL(118) = 1
1481C calculation of alpha_em
1482 IPAMDL(120) = 1
1483C strict pt cutoff for gamma-gamma events
1484 IPAMDL(121) = 0
1485C photon virtuality sampled in photon flux approximations
1486 IPAMDL(174) = 1
1487C photon-pomeron: 0,1,2: both,left,right photon emission
1488 IPAMDL(175) = 0
1489C keep full history information in PHOJET-JETSET interface
1490 IPAMDL(178) = 1
1491C max. number of conservation law violations allowed in one run
1492 IPAMDL(179) = 20
1493C selection of soft X values
1494C max. iteration number in PHO_SELSXS
1495 IPAMDL(180) = 50
1496C max. iteration number in PHO_SELSXR
1497 IPAMDL(181) = 200
1498C max. iteration number in PHO_SELSX2
1499 IPAMDL(182) = 100
1500C max. iteration number in PHO_SELSXI
1501 IPAMDL(183) = 50
1502
1503C initialize /PROBAB/
1504 IEEMAX = IEETA1
1505 IMAX = IIMAX
1506 KMAX = KKMAX
1507
1508 DO 20 I=1,30
1509 PARMDL(300+I) = -100000.D0
1510 20 CONTINUE
1511C initialize /POHDRN/
1512 QMASS(1) = PARMDL(151)
1513 QMASS(2) = PARMDL(152)
1514 QMASS(3) = PARMDL(153)
1515 QMASS(4) = PARMDL(154)
1516 QMASS(5) = PARMDL(155)
1517 QMASS(6) = PARMDL(156)
1518 BET = 8.D0
1519 PCOUDI = 0.D0
1520 VALPRG(1) = 1.D0
1521 VALPRG(2) = 1.D0
1522C number of light flavours (quarks treated as massless)
1523 NFS = 4
1524C initialize /POCUT1/
1525 PTCUT(1) = PARMDL(36)
1526 PTCUT(2) = PARMDL(37)
1527 PTCUT(3) = PARMDL(38)
1528 PTCUT(4) = PARMDL(39)
1529 PSOMIN = 0.D0
1530 XSOMIN = 0.D0
1531C initialize /POHAPA/
1532 NFbeta = 4
1533 NF = 4
1534 BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
1535 BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
1536 BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
1537 BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
1538C initialize /POGAUP/
1539 NGAUP1 = 12
1540 NGAUP2 = 12
1541 NGAUET = 16
1542 NGAUIN = 12
1543 NGAUSO = 96
1544C initialize //
1545 DO 30 I=1,100
1546 IDEB(I) = 0
1547 30 CONTINUE
1548C initialize /PROCES/
1549 DO 35 I=1,11
1550 IPRON(I,1) = 1
1551 35 CONTINUE
1552
1553C DPMJET default: no elastic scattering
1554 IPRON(2,1) = 0
1555
1556 DO 36 K=2,4
1557 DO 37 I=2,11
1558 IPRON(I,K) = 0
1559 37 CONTINUE
1560 IPRON(1,K) = 1
1561 IPRON(8,K) = 1
1562 36 CONTINUE
1563C initialize /POSVDM/
1564 TWOPIM = 0.28D0
1565 RMIN(1) = 0.285D0
1566 RMIN(2) = 0.45D0
1567 RMIN(3) = 1.D0
1568 RMIN(4) = TWOPIM
1569 VMAS(1) = 0.770D0
1570 VMAS(2) = 0.787D0
1571 VMAS(3) = 1.02D0
1572 VMAS(4) = TWOPIM
1573 GAMM(1) = 0.155D0
1574 GAMM(2) = 0.01D0
1575 GAMM(3) = 0.0045D0
1576 GAMM(4) = 1.D0
1577 RMAX(1) = VMAS(1)+TWOPIM
1578 RMAX(2) = VMAS(2)+TWOPIM
1579 RMAX(3) = VMAS(3)+TWOPIM
1580 RMAX(4) = VMAS(1)+TWOPIM
1581 VMSL(1) = 11.D0
1582 VMSL(2) = 10.D0
1583 VMSL(3) = 6.D0
1584 VMSL(4) = 4.D0
1585 VMFA(1) = 0.0033D0
1586 VMFA(2) = 0.00036D0
1587 VMFA(3) = 0.0002D0
1588 VMFA(4) = 0.0002D0
1589C initialize /PODGL1/
1590 Q2MISR(1) = PARMDL(36)**2
1591 Q2MISR(2) = PARMDL(36)**2
1592 PMISR(1) = 1.D0
1593 PMISR(2) = 1.D0
1594 ZMISR(1) = 0.001D0
1595 ZMISR(2) = 0.001D0
1596 AL2ISR(1) = 0.046D0
1597 AL2ISR(2) = 0.046D0
1598 NFSISR = 4
1599C initialize /POPISR/
1600 DO 40 I=1,50
1601 IPOISR(1,2,I) = 0
1602 IPOISR(2,2,I) = 0
1603 40 CONTINUE
1604C initialize /POHPRO/
1605 PROC(0) = 'sum over processes'
1606 PROC(1) = 'G +G --> G +G '
1607 PROC(2) = 'Q +QB --> G +G '
1608 PROC(3) = 'G +Q --> G +Q '
1609 PROC(4) = 'G +G --> Q +QB '
1610 PROC(5) = 'Q +QB --> Q +QB '
1611 PROC(6) = 'Q +QB --> QP +QBP'
1612 PROC(7) = 'Q +Q --> Q +Q '
1613 PROC(8) = 'Q +QP --> Q +QP '
1614 PROC(9) = 'resolved processes'
1615 PROC(10) = 'gam+Q --> G +Q '
1616 PROC(11) = 'gam+G --> Q +QB '
1617 PROC(12) = 'Q +gam--> G +Q '
1618 PROC(13) = 'G +gam--> Q +QB '
1619 PROC(14) = 'gam+gam--> Q +QB '
1620 PROC(15) = 'direct processes '
1621 PROC(16) = 'gam+gam--> l+ +l- '
1622
1623C initialize /POHRCS/
1624 do M=1,Max_pro_2
1625 HWgx(M) = 0.D0
1626 HSig(M) = 0.D0
1627 Hdpt(M) = 0.D0
1628 enddo
1629 DO I=0,4
1630 DO M=-1,Max_pro_2
1631C switch all hard subprocesses on
1632 MH_pro_on(M,I) = 1
1633C reset all counters
1634 MH_tried(M,I) = 0
1635 MH_acc_1(M,I) = 0
1636 MH_acc_2(M,I) = 0
1637 ENDDO
1638 MH_pro_on(16,I) = 0
1639 ENDDO
1640
1641C initialize /POHTAB/
1642 do I=0,4
1643 IH_Ecm_up(I) = 0
1644 IH_Q2a_up(I) = 0
1645 IH_Q2b_up(I) = 0
1646 HEcm_tab(1,I) = 0.D0
1647 enddo
1648 HEcm_last = 0.D0
1649 IHa_last = 0.D0
1650 IHb_last = 0.D0
1651
1652C initialize /POFSRC/
1653 IGHEL(1) = -1
1654 IGHEL(2) = -1
1655C initialize /LEPCUT/
1656 ECMIN = 5.D0
1657 ECMAX = 1.D+30
1658 EEMIN1 = 1.D0
1659 EEMIN2 = 1.D0
1660 YMAX1 = -1.D0
1661 YMAX2 = -1.D0
1662 THMIN1 = 0.D0
1663 THMAX1 = PI
1664 THMIN2 = 0.D0
1665 THMAX2 = PI
1666 ITAG1 = 1
1667 ITAG2 = 1
1668C initialize /POWGHT/
1669 DO 70 I=1,20
1670 HSWCUT(I) = 0.D0
1671 ISWCUT(I) = 0
1672 70 CONTINUE
1673 EVWGHT(1) = 1.D0
1674 IVWGHT(1) = 0
1675 SIGGEN(1) = 0.D0
1676 SIGGEN(2) = 0.D0
1677 SIGGEN(3) = 0.D0
1678 SIGGEN(4) = 0.D0
1679
1680 END
1681
1682*$ CREATE PHO_PARDAT.FOR
1683*COPY PHO_PARDAT
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
2481*$ CREATE PHO_PRESEL.FOR
2482*COPY PHO_PRESEL
2483CDECK ID>, PHO_PRESEL
2484 SUBROUTINE PHO_PRESEL(MODE,IREJ)
2485C**********************************************************************
2486C
2487C user specific function to pre-select events during generation
2488C
2489C input: MODE 5 electron and photon kinematics
2490C 10 process and number of cut Pomerons
2491C 15 partons without construction of strings
2492C 20 partons assigned to strings
2493C 25 after fragmentation, complete final state
2494C
2495C output: IREJ 0 event accepted
2496C 50 event rejected
2497C
2498C**********************************************************************
2499 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2500 SAVE
2501
2502C input/output channels
2503 INTEGER LI,LO
2504 COMMON /POINOU/ LI,LO
2505C event debugging information
2506 INTEGER NMAXD
2507 PARAMETER (NMAXD=100)
2508 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2509 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2510 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2511 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2512
2513C standard particle data interface
2514 INTEGER NMXHEP
2515
2516 PARAMETER (NMXHEP=4000)
2517
2518 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
2519 DOUBLE PRECISION PHEP,VHEP
2520 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2521 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2522 & VHEP(4,NMXHEP)
2523C extension to standard particle data interface (PHOJET specific)
2524 INTEGER IMPART,IPHIST,ICOLOR
2525 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
2526
2527C global event kinematics and particle IDs
2528 INTEGER IFPAP,IFPAB
2529 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2530 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2531C gamma-lepton or gamma-hadron vertex information
2532 INTEGER IGHEL,IDPSRC,IDBSRC
2533 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2534 & RADSRC,AMSRC,GAMSRC
2535 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2536 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2537 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2538C hard scattering data
2539 INTEGER MSCAHD
2540 PARAMETER ( MSCAHD = 50 )
2541 INTEGER LSCAHD,LSC1HD,LSIDX,
2542 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
2543 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
2544 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
2545 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
2546 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
2547 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
2548 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
2549 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
2550 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
2551C event weights and generated cross section
2552 INTEGER IPOWGC,ISWCUT,IVWGHT
2553 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2554 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2555 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2556
2557 IREJ = 0
2558
2559* XBJ = GQ2(2)/(GGECM**2+GQ2(2))
2560* IF(XBJ.LT.0.002D0) IREJ = 1
2561
2562 END
2563
2564*$ CREATE PHO_FIXCOL.FOR
2565*COPY PHO_FIXCOL
2566CDECK ID>, PHO_FIXCOL
2567 SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
2568C**********************************************************************
2569C
2570C interface to call PHOJET (fixed energy run) with
2571C collider kinematics
2572C
2573C equivalen photon approximation to get photon flux
2574C
2575C input: NEV number of events to generate
2576C THETA azimuthal angle (micro radians)
2577C PHI beam crossing angle
2578C (with respect to x, in degrees)
2579C E1 energy of particle 1 (+z direction, GeV)
2580C E2 energy of particle 2 (-z direction, GeV)
2581C
2582C note: particle types have to be specified before
2583C with PHO_SETPAR
2584C
2585C**********************************************************************
2586 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2587 SAVE
2588
2589 PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
2590
2591C input/output channels
2592 INTEGER LI,LO
2593 COMMON /POINOU/ LI,LO
2594C event debugging information
2595 INTEGER NMAXD
2596 PARAMETER (NMAXD=100)
2597 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2598 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2599 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2600 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2601C general process information
2602 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2603 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2604C global event kinematics and particle IDs
2605 INTEGER IFPAP,IFPAB
2606 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2607 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2608C model switches and parameters
2609 CHARACTER*8 MDLNA
2610 INTEGER ISWMDL,IPAMDL
2611 DOUBLE PRECISION PARMDL
2612 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2613C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2614 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2615 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2616 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2617 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2618C integration precision for hard cross sections (obsolete)
2619 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2620 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2621C event weights and generated cross section
2622 INTEGER IPOWGC,ISWCUT,IVWGHT
2623 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2624 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2625 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2626
2627 DIMENSION P1(4),P2(4)
2628
2629C remnant initialization (only needed for DPMJET)
2630 ISAVP1 = IFPAP(1)
2631 ISAVB1 = IFPAB(1)
2632 IF(IFPAP(1).EQ.81) THEN
2633 IFPAP(1) = IDEQP(1)
2634 IFPAB(1) = IDEQB(1)
2635 ENDIF
2636 ISAVP2 = IFPAP(2)
2637 ISAVB2 = IFPAB(2)
2638 IF(IFPAP(2).EQ.82) THEN
2639 IFPAP(2) = IDEQP(2)
2640 IFPAB(2) = IDEQB(2)
2641 ENDIF
2642 PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
2643 PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
2644 PP1 = SQRT(E1**2-PMASS1**2)
2645 PP2 = SQRT(E2**2-PMASS2**2)
2646C beam crossing angle
2647 TH = 1.D-6*THETA/2.D0
2648 PH = PHI*BOG
2649 P1(1) = PP1*SIN(TH)*COS(PH)
2650 P1(2) = PP1*SIN(TH)*SIN(PH)
2651 P1(3) = PP1*COS(TH)
2652 P1(4) = E1
2653 P2(1) = PP2*SIN(TH)*COS(PH)
2654 P2(2) = PP2*SIN(TH)*SIN(PH)
2655 P2(3) = -PP2*COS(TH)
2656 P2(4) = E2
2657 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2658 IFPAP(1) = ISAVP1
2659 IFPAB(1) = ISAVB1
2660 IFPAP(2) = ISAVP2
2661 IFPAB(2) = ISAVB2
2662 ITRY = 0
2663 CALL PHO_PHIST(-1,SIGMAX)
2664 CALL PHO_LHIST(-1,SIGMAX)
2665C test of DPMJET interface (default is IPAMDL(13)=0)
2666 if(IPAMDL(13).gt.0) then
2667 MODE = IPAMDL(13)
2668 IPAMDL(13) = 0
2669 else
2670 MODE = 1
2671 endif
2672C main generation loop
2673 DO 50 I=1,NEV
2674 55 CONTINUE
2675 ITRY = ITRY+1
2676 CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
2677 IF(IREJ.NE.0) GOTO 55
2678 CALL PHO_PHIST(1,HSWGHT(0))
2679 CALL PHO_LHIST(1,HSWGHT(0))
2680 50 CONTINUE
2681
2682 IF(NEV.GT.0) THEN
2683 SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2684 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2685 & '=========================================================',
2686 & ' ***** simulated cross section: ',SIGMAX,' mb *****',
2687 & '========================================================='
2688 CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2689 CALL PHO_PHIST(-2,SIGMAX)
2690 CALL PHO_LHIST(-2,SIGMAX)
2691 ELSE
2692 WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
2693 ENDIF
2694
2695 END
2696
2697*$ CREATE PHO_FIXLAB.FOR
2698*COPY PHO_FIXLAB
2699CDECK ID>, PHO_FIXLAB
2700 SUBROUTINE PHO_FIXLAB(PLAB,NEV)
2701C**********************************************************************
2702C
2703C interface to call PHOJET (fixed energy run) with
2704C LAB kinematics (second particle as target)
2705C
2706C equivalent photon approximation to get photon flux
2707C
2708C input: NEV number of events to generate
2709C PLAB LAB momentum of particle 1
2710C
2711C note: particle types have to be specified before
2712C with PHO_SETPAR
2713C
2714C**********************************************************************
2715 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2716 SAVE
2717
2718C input/output channels
2719 INTEGER LI,LO
2720 COMMON /POINOU/ LI,LO
2721C event debugging information
2722 INTEGER NMAXD
2723 PARAMETER (NMAXD=100)
2724 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2725 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2726 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2727 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2728C general process information
2729 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2730 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2731C global event kinematics and particle IDs
2732 INTEGER IFPAP,IFPAB
2733 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2734 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2735C model switches and parameters
2736 CHARACTER*8 MDLNA
2737 INTEGER ISWMDL,IPAMDL
2738 DOUBLE PRECISION PARMDL
2739 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2740C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2741 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2742 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2743 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2744 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2745C integration precision for hard cross sections (obsolete)
2746 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2747 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2748C event weights and generated cross section
2749 INTEGER IPOWGC,ISWCUT,IVWGHT
2750 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2751 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2752 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2753
2754 DIMENSION P1(4),P2(4)
2755
2756C remnant initialization (only needed for DPMJET)
2757 SPCM = PLAB
2758 ISAVP1 = IFPAP(1)
2759 ISAVB1 = IFPAB(1)
2760 IF(IFPAP(1).EQ.81) THEN
2761 IFPAP(1) = IDEQP(1)
2762 IFPAB(1) = IDEQB(1)
2763 ENDIF
2764 ISAVP2 = IFPAP(2)
2765 ISAVB2 = IFPAB(2)
2766 IF(IFPAP(2).EQ.82) THEN
2767 IFPAP(2) = IDEQP(2)
2768 IFPAB(2) = IDEQB(2)
2769 ENDIF
2770C get momenta in LAB system
2771 PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
2772 PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
2773 IF(PMASS2.LT.0.1D0) THEN
2774 WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
2775 & 'no LAB system possible',IFPAB(1),IFPAB(2)
2776 ELSE
2777 P1(1) = 0.D0
2778 P1(2) = 0.D0
2779 P1(3) = PLAB
2780 P1(4) = SQRT(PMASS1+PLAB**2)
2781 P2(1) = 0.D0
2782 P2(2) = 0.D0
2783 P2(3) = 0.D0
2784 P2(4) = SQRT(PMASS2)
2785 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2786 IFPAP(1) = ISAVP1
2787 IFPAB(1) = ISAVB1
2788 IFPAP(2) = ISAVP2
2789 IFPAB(2) = ISAVB2
2790 ITRY = 0
2791 CALL PHO_PHIST(-1,SIGMAX)
2792 CALL PHO_LHIST(-1,SIGMAX)
2793C event generation loop
2794 DO 40 I=1,NEV
2795 45 CONTINUE
2796 ITRY = ITRY+1
2797 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
2798 IF(IREJ.NE.0) GOTO 45
2799 CALL PHO_LHIST(1,HSWGHT(0))
2800
2801 CALL PHO_PHIST(10,HSWGHT(0))
2802
2803 40 CONTINUE
2804 IF(NEV.GT.0) THEN
2805 SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2806 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2807 & '=========================================================',
2808 & ' ***** simulated cross section: ',SIGMAX,' mb *****',
2809 & '========================================================='
2810 CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2811 CALL PHO_PHIST(-2,SIGMAX)
2812 CALL PHO_LHIST(-2,SIGMAX)
2813 ELSE
2814 WRITE(LO,'(1X,A,I5)')
2815 & 'PHO_FIXLAB: no events simulated',NEV
2816 ENDIF
2817 ENDIF
2818
2819 END
2820
2821*$ CREATE PHO_GPHERA.FOR
2822*COPY PHO_GPHERA
2823CDECK ID>, PHO_GPHERA
2824 SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
2825C**********************************************************************
2826C
2827C interface to call PHOJET (variable energy run) with
2828C HERA kinematics, photon as particle 2
2829C
2830C equivalent photon approximation to get photon flux
2831C
2832C input: NEVENT number of events to generate
2833C EE1 proton energy (LAB system)
2834C EE2 electron energy (LAB system)
2835C from /POFCUT/:
2836C YMIN2 lower limit of Y
2837C (energy fraction taken by photon from electron)
2838C YMAX2 upper limit of Y
2839C Q2MIN2 lower limit of photon virtuality
2840C Q2MAX2 upper limit of photon virtuality
2841C
2842C**********************************************************************
2843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2844 SAVE
2845
2846 PARAMETER ( DEPS = 1.D-10,
2847 & PI = 3.14159265359D0 )
2848
2849C input/output channels
2850 INTEGER LI,LO
2851 COMMON /POINOU/ LI,LO
2852C event debugging information
2853 INTEGER NMAXD
2854 PARAMETER (NMAXD=100)
2855 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2856 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2857 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2858 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2859C model switches and parameters
2860 CHARACTER*8 MDLNA
2861 INTEGER ISWMDL,IPAMDL
2862 DOUBLE PRECISION PARMDL
2863 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2864C photon flux kinematics and cuts
2865 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
2866 & YMIN1,YMAX1,YMIN2,YMAX2,
2867 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2868 & THMIN1,THMAX1,THMIN2,THMAX2
2869 INTEGER ITAG1,ITAG2
2870 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
2871 & YMIN1,YMAX1,YMIN2,YMAX2,
2872 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2873 & THMIN1,THMAX1,THMIN2,THMAX2,
2874 & ITAG1,ITAG2
2875C gamma-lepton or gamma-hadron vertex information
2876 INTEGER IGHEL,IDPSRC,IDBSRC
2877 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2878 & RADSRC,AMSRC,GAMSRC
2879 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2880 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2881 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2882C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2883 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2884 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2885 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2886 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2887C event weights and generated cross section
2888 INTEGER IPOWGC,ISWCUT,IVWGHT
2889 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2890 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2891 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2892
2893 DIMENSION P1(4),P2(4)
2894
2895 WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
2896C assign particle momenta according to HERA kinematics
2897C proton data
2898 PROM = PHO_PMASS(2212,1)
2899 PROM2 = PROM**2
2900 IDPSRC(1) = 0
2901 IDBSRC(1) = 0
2902C electron data
2903 ELEM = 0.512D-03
2904 ELEM2 = ELEM**2
2905 AMSRC(2) = ELEM
2906 IDPSRC(2) = 11
2907 IDBSRC(2) = ipho_pdg2id(11)
2908C
2909 Q2MIN = Q2MIN2
2910 Q2MAX = Q2MAX2
2911C
2912 XIMAX = LOG(YMAX2)
2913 XIMIN = LOG(YMIN2)
2914 XIDEL = XIMAX-XIMIN
2915C
2916 IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
2917 & WRITE(LO,'(/1X,A,1P2E11.4)')
2918 & 'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
2919 & Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
2920C
2921 Max_tab = 50
2922 DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
2923 FLUXT = 0.D0
2924 FLUXL = 0.D0
2925 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
2926 & 'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
2927 DO 100 I=1,Max_tab
2928 Y = EXP(XIMIN+DELLY*DBLE(I-1))
2929 Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
2930 FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2931 & -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
2932 FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
2933 FLUXT = FLUXT + Y*FFT
2934 FLUXL = FLUXL + Y*FFL
2935 IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
2936 100 CONTINUE
2937 FLUXT = FLUXT*DELLY
2938 FLUXL = FLUXL*DELLY
2939 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
2940 & 'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
2941C
2942 AY = 0.D0
2943 AY2 = 0.D0
2944 YY = YMIN2
2945 Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2946 WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
2947 & -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
2948 IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
2949C
2950C initialization of PHOJET at upper energy limit
2951C proton momentum
2952 P1(1) = 0.D0
2953 P1(2) = 0.D0
2954 P1(3) = SQRT(EE1**2-PROM2+DEPS)
2955 P1(4) = EE1
2956C photon momentum
2957 EGAM = YMAX2*EE2
2958 P2(1) = 0.D0
2959 P2(2) = 0.D0
2960 P2(3) = -EGAM
2961 P2(4) = EGAM
2962C sum of both photon polarizations
2963 IGHEL(2) = -1
2964C
2965 CALL PHO_SETPAR(1,2212,0,0.D0)
2966 CALL PHO_SETPAR(2,22,0,0.D0)
2967 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2968 CALL PHO_PHIST(-1,SIGMAX)
2969 CALL PHO_LHIST(-1,SIGMAX)
2970C
2971C generation of events, flux calculation
2972
2973 ECMIN2 = ECMIN**2
2974 ECMAX2 = ECMAX**2
2975 AY = 0.D0
2976 AY2 = 0.D0
2977 Q22MIN = 1.D30
2978 Q22AVE = 0.D0
2979 Q22AV2 = 0.D0
2980 Q22MAX = 0.D0
2981 AN2MIN = 1.D30
2982 AN2MAX = 0.D0
2983 YY2MIN = 1.D30
2984 YY2MAX = 0.D0
2985 NITER = NEVENT
2986 ITRY = 0
2987 ITRW = 0
2988 DO 200 I=1,NITER
2989 150 CONTINUE
2990C sample y
2991 ITRY = ITRY+1
2992 175 CONTINUE
2993 ITRW = ITRW+1
2994 YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
2995 IF(ISWMDL(10).GE.2) THEN
2996 YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
2997 ELSE
2998 YEFF = 1.D0+(1.D0-YY)**2
2999 ENDIF
3000 Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
3001 Q2LOG = LOG(Q2MAX/Q2LOW)
3002 WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
3003 IF(WGMAX.LT.WGH) THEN
3004 WRITE(LO,'(1X,A,3E12.5)')
3005 & 'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
3006 ENDIF
3007 IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
3008C sample Q2
3009 IF(IPAMDL(174).EQ.1) THEN
3010 185 CONTINUE
3011 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3012 WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
3013 IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
3014 ELSE
3015 Q2 = Q2LOW
3016 ENDIF
3017C
3018
3019C incoming electron
3020 PINI(1,2) = 0.D0
3021 PINI(2,2) = 0.D0
3022 PINI(3,2) = -EE2
3023 PINI(4,2) = EE2
3024 PINI(5,2) = 0.D0
3025C outgoing electron
3026 YQ2 = SQRT((1.D0-YY)*Q2)
3027 Q2E = Q2/(4.D0*EE2)
3028 E1Y = EE2*(1.D0-YY)
3029 CALL PHO_SFECFE(SIF,COF)
3030 PFIN(1,2) = YQ2*COF
3031 PFIN(2,2) = YQ2*SIF
3032 PFIN(3,2) = -E1Y+Q2E
3033 PFIN(4,2) = E1Y+Q2E
3034 PFIN(5,2) = 0.D0
3035C set /POFSRC/
3036 GYY(2) = YY
3037 GQ2(2) = Q2
3038C polar angle
3039 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3040C electron tagger
3041 IF(PFIN(4,2).GT.EEMIN2) THEN
3042 IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
3043 ENDIF
3044C azimuthal angle
3045 PFPHI(2) = ATAN2(COF,SIF)
3046C photon momentum
3047 P2(1) = -PFIN(1,2)
3048 P2(2) = -PFIN(2,2)
3049 P2(3) = PINI(3,2)-PFIN(3,2)
3050 P2(4) = PINI(4,2)-PFIN(4,2)
3051C proton momentum
3052 P1(1) = 0.D0
3053 P1(2) = 0.D0
3054 P1(3) = SQRT(EE1**2-PROM2)
3055 P1(4) = EE1
3056C ECMS cut
3057 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3058 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3059 IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
3060 GGECM = SQRT(GGECM)
3061C
3062 PGAM(1,2) = P2(1)
3063 PGAM(2,2) = P2(2)
3064 PGAM(3,2) = P2(3)
3065 PGAM(4,2) = P2(4)
3066 PGAM(5,2) = -SQRT(Q2)
3067C photon helicity
3068 IF(ISWMDL(10).GE.2) THEN
3069 WGH = YEFF-2.D0*ELEM2*YY**2/Q2
3070 WGHL = 2.D0*(1-YY)
3071 IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
3072 IGHEL(2) = 1
3073 ELSE
3074 IGHEL(2) = 0
3075 ENDIF
3076 ELSE
3077 IGHEL(2) = -1
3078 ENDIF
3079C user cuts
3080 CALL PHO_PRESEL(5,IREJ)
3081 IF(IREJ.NE.0) GOTO 175
3082C event generation
3083 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3084 IF(IREJ.NE.0) GOTO 150
3085
3086C statistics
3087 AY = AY+YY
3088 AY2 = AY2+YY*YY
3089 YY2MIN = MIN(YY2MIN,YY)
3090 YY2MAX = MAX(YY2MAX,YY)
3091 Q22MIN = MIN(Q22MIN,Q2)
3092 Q22MAX = MAX(Q22MAX,Q2)
3093 Q22AVE = Q22AVE+Q2
3094 Q22AV2 = Q22AV2+Q2*Q2
3095 AN2MIN = MIN(AN2MIN,PFTHE(2))
3096 AN2MAX = MAX(AN2MAX,PFTHE(2))
3097C histograms
3098 CALL PHO_PHIST(1,HSWGHT(0))
3099 CALL PHO_LHIST(1,HSWGHT(0))
3100 200 CONTINUE
3101C
3102 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
3103 WGY = WGY*LOG(YMAX2/YMIN2)
3104 AY = AY/DBLE(NITER)
3105 AY2 = AY2/DBLE(NITER)
3106 DAY = SQRT((AY2-AY**2)/DBLE(NITER))
3107 Q22AVE = Q22AVE/DBLE(NITER)
3108 Q22AV2 = Q22AV2/DBLE(NITER)
3109 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3110 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
3111C output of histograms
3112 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3113 &'=========================================================',
3114 &' ***** simulated cross section: ',WEIGHT,' mb *****',
3115 &'========================================================='
3116 WRITE(LO,'(//1X,A,3I10)')
3117 & 'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
3118 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
3119 & WGY,WEIGHT
3120 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY ',AY,DAY
3121 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON ',
3122 & YY2MIN,YY2MAX
3123 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 ',
3124 & Q22AVE,Q22AV2
3125 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON ',
3126 & Q22MIN,Q22MAX
3127 WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
3128 & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3129C
3130 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3131 IF(NITER.GT.1) THEN
3132 CALL PHO_PHIST(-2,WEIGHT)
3133 CALL PHO_LHIST(-2,WEIGHT)
3134 ELSE
3135 WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
3136 ENDIF
3137
3138 END
3139
3140*$ CREATE PHO_GGEPEM.FOR
3141*COPY PHO_GGEPEM
3142CDECK ID>, PHO_GGEPEM
3143 SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
3144C**********************************************************************
3145C
3146C interface to call PHOJET (variable energy run) for
3147C gamma-gamma collisions on e+e- collider
3148C
3149C fully differential equivalent (improved) photon approximation
3150C to get photon flux
3151C
3152C input: EE1 LAB system energy of electron/positron 1
3153C EE2 LAB system energy of electron/positron 2
3154C NEVENT >0 number of events to generate
3155C -1 initialization
3156C -2 final call (cross section calculation)
3157C from /LEPCUT/:
3158C YMIN1 lower limit of Y1
3159C (energy fraction taken by photon from electron)
3160C YMAX1 upper limit of Y1
3161C Q2MIN1 lower limit of photon virtuality
3162C Q2MAX1 upper limit of photon virtuality
3163C THMIN1 lower limit of scattered electron
3164C THMAX1 upper limit of scattered electron
3165C YMIN2 lower limit of Y2
3166C (energy fraction taken by photon from electron)
3167C YMAX2 upper limit of Y2
3168C Q2MIN2 lower limit of photon virtuality
3169C Q2MAX2 upper limit of photon virtuality
3170C THMIN2 lower limit of scattered electron
3171C THMAX2 upper limit of scattered electron
3172C
3173C output: after final call with NEVENT=-2
3174C EE1 e+ e- cross section (mb)
3175C EE2 gamma-gamma cross section (mb)
3176C
3177C**********************************************************************
3178
3179 IMPLICIT NONE
3180
3181 SAVE
3182
3183 DOUBLE PRECISION EE1,EE2
3184 INTEGER NEVENT
3185
3186C input/output channels
3187 INTEGER LI,LO
3188 COMMON /POINOU/ LI,LO
3189C event debugging information
3190 INTEGER NMAXD
3191 PARAMETER (NMAXD=100)
3192 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3193 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3194 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3195 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3196C model switches and parameters
3197 CHARACTER*8 MDLNA
3198 INTEGER ISWMDL,IPAMDL
3199 DOUBLE PRECISION PARMDL
3200 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3201C some constants
3202 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3203 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3204 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3205C photon flux kinematics and cuts
3206 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
3207 & YMIN1,YMAX1,YMIN2,YMAX2,
3208 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3209 & THMIN1,THMAX1,THMIN2,THMAX2
3210 INTEGER ITAG1,ITAG2
3211 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
3212 & YMIN1,YMAX1,YMIN2,YMAX2,
3213 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3214 & THMIN1,THMAX1,THMIN2,THMAX2,
3215 & ITAG1,ITAG2
3216C gamma-lepton or gamma-hadron vertex information
3217 INTEGER IGHEL,IDPSRC,IDBSRC
3218 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3219 & RADSRC,AMSRC,GAMSRC
3220 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3221 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3222 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3223C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3224 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3225 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3226 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3227 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3228C event weights and generated cross section
3229 INTEGER IPOWGC,ISWCUT,IVWGHT
3230 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
3231 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
3232 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
3233
3234C external functions
3235 DOUBLE PRECISION DT_RNDM
3236
3237C local variables
3238 DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
3239 & COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
3240 & ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
3241 & FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
3242 & Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
3243 & Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
3244 & THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
3245 & WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
3246 & YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
3247
3248 INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
3249 & ITRY_high,K,Max_tab,NITER,ITG1,ITG2
3250
3251 DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
3252 integer ipho_pdg2id
3253
3254C initialization of event generation
3255
3256 if(NEVENT.eq.-1) then
3257
3258 DO 10 I=1,4
3259 IHETRY(I) = 0
3260 IHEAC1(I) = 0
3261 IHEAC2(I) = 0
3262 10 CONTINUE
3263
3264 WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
3265
3266C electron data
3267 ELEM = 0.512D-03
3268 ELEM2 = ELEM**2
3269 AMSRC(1) = ELEM
3270 AMSRC(2) = ELEM
3271C lepton numbers
3272 IDPSRC(1) = 11
3273 IDPSRC(2) = -11
3274 IDBSRC(1) = ipho_pdg2id(11)
3275 IDBSRC(2) = ipho_pdg2id(-11)
3276
3277C check/update kinematic limitations
3278
3279 Ymi = min(Ymax1,1.D0-ELEM/EE1)
3280 if(Ymi.lt.Ymax1) then
3281 WRITE(LO,'(/1X,A,2E12.5)')
3282 & 'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
3283 Ymax1 = YMI
3284 endif
3285 Ymi = min(Ymax2,1.D0-ELEM/EE2)
3286 if(Ymi.lt.Ymax2) then
3287 WRITE(LO,'(/1X,A,2E12.5)')
3288 & 'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
3289 Ymax2 = YMI
3290 endif
3291
3292 YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
3293 IF(YMIN1.LT.YMI) THEN
3294 WRITE(LO,'(/1X,A,2E12.5)')
3295 & 'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
3296 YMIN1 = YMI
3297 ELSE IF(YMIN1.GT.YMI) THEN
3298 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3299 & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
3300 & ' INSTEAD OF',YMIN1
3301 ENDIF
3302 YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
3303 IF(YMIN2.LT.YMI) THEN
3304 WRITE(LO,'(/1X,A,2E12.5)')
3305 & 'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
3306 YMIN2 = YMI
3307 ELSE IF(YMIN2.GT.YMI) THEN
3308 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3309 & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
3310 & ' INSTEAD OF',YMIN2
3311 ENDIF
3312
3313C store COS of angular tagging range
3314 THMIC1 = COS(MAX(0.D0,THMIN1))
3315 THMAC1 = COS(MIN(THMAX1,PI))
3316 THMIC2 = COS(MAX(0.D0,THMIN2))
3317 THMAC2 = COS(MIN(THMAX2,PI))
3318
3319 X1MAX = LOG(YMAX1)
3320 X1MIN = LOG(YMIN1)
3321 X1DEL = X1MAX-X1MIN
3322 X2MAX = LOG(YMAX2)
3323 X2MIN = LOG(YMIN2)
3324 X2DEL = X2MAX-X2MIN
3325
3326C debug: integrated photon flux
3327
3328 if(IDEB(30).ge.1) then
3329 Max_tab = 50
3330 FLUXT = 0.D0
3331 FLUXL = 0.D0
3332 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
3333 IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
3334 & 'table of photon flux (trans/long side 1)',Max_tab
3335 do I=1,Max_tab
3336 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
3337 if((1.D0-Y1).gt.1.D-8) then
3338 Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
3339 else
3340 Q2low1 = 2.D0*Q2max1
3341 endif
3342 if(Q2low1.lt.Q2max1) then
3343 FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
3344 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
3345 FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
3346 else
3347 FFT = 0.D0
3348 FFL = 0.D0
3349 endif
3350 FLUXT = FLUXT + Y1*FFL
3351 FLUXL = FLUXL + Y1*FFT
3352 IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
3353 enddo
3354 FLUXT = FLUXT*DELLY
3355 FLUXL = FLUXL*DELLY
3356 WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
3357 & 'integrated flux (trans/long side 1):',FLUXT,FLUXL
3358 endif
3359
3360C maximum weight
3361
3362 Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
3363 Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
3364 Y1 = YMIN1
3365 Y2 = YMIN2
3366 IF(ISWMDL(10).GE.2) THEN
3367C long. and transversely polarized photons
3368 WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
3369 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3370 & *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
3371 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3372 ELSE
3373C transversely polarized photons only
3374 WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
3375 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3376 & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
3377 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3378 ENDIF
3379
3380C initialize gamma-gamma event generator
3381
3382C photon 1
3383 EGAM = YMAX1*EE1
3384 P1(1) = 0.D0
3385 P1(2) = 0.D0
3386 P1(3) = SQRT(EGAM**2-Q2LOW1)
3387 P1(4) = EGAM
3388C photon 2
3389 EGAM = YMAX2*EE2
3390 P2(1) = 0.D0
3391 P2(2) = 0.D0
3392 P2(3) = -SQRT(EGAM**2-Q2LOW2)
3393 P2(4) = EGAM
3394C sum of helicities
3395 IGHEL(1) = -1
3396 IGHEL(2) = -1
3397
3398C set min. energy for interpolation tables
3399 parmdl(19) = min(parmdl(19),ecmin)
3400
3401C initialize event gneration
3402 CALL PHO_SETPAR(1,22,0,0.D0)
3403 CALL PHO_SETPAR(2,22,0,0.D0)
3404 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
3405 CALL PHO_PHIST(-1,SIGMAX)
3406 CALL PHO_LHIST(-1,SIGMAX)
3407
3408C generation of events, flux calculation
3409
3410 ECMIN2 = ECMIN**2
3411 ECMAX2 = ECMAX**2
3412 ECFRAC = ECMIN2/(4.D0*EE1*EE2)
3413 AY1 = 0.D0
3414 AY2 = 0.D0
3415 AYS1 = 0.D0
3416 AYS2 = 0.D0
3417 Q21MIN = 1.D30
3418 Q22MIN = 1.D30
3419 Q21MAX = 0.D0
3420 Q22MAX = 0.D0
3421 Q21AVE = 0.D0
3422 Q22AVE = 0.D0
3423 Q21AV2 = 0.D0
3424 Q22AV2 = 0.D0
3425 AN1MIN = 1.D30
3426 AN2MIN = 1.D30
3427 AN1MAX = 0.D0
3428 AN2MAX = 0.D0
3429 YY1MIN = 1.D30
3430 YY2MIN = 1.D30
3431 YY1MAX = 0.D0
3432 YY2MAX = 0.D0
3433 NITER = 0
3434 ITRY_low = 0
3435 ITRY_high = 0
3436 ITRW_low = 0
3437 ITRW_high = 0
3438
3439C generate NEVENT events (might be just 1 per call)
3440
3441 else if(NEVENT.gt.0) then
3442
3443 NITER = NITER+NEVENT
3444
3445 DO 200 I=1,NEVENT
3446
3447C sample y1, y2
3448 150 CONTINUE
3449 ITRY_low = ITRY_low+1
3450 if(ITRY_low.eq.1000000) then
3451 ITRY_low = 0
3452 ITRY_high = ITRY_high+1
3453 endif
3454
3455 175 CONTINUE
3456 ITRW_low = ITRW_low+1
3457 if(ITRW_low.eq.1000000) then
3458 ITRW_low = 0
3459 ITRW_high = ITRW_high+1
3460 endif
3461
3462 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
3463 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
3464 IF(Y1*Y2.LT.ECFRAC) GOTO 175
3465 IF(ISWMDL(10).GE.2) THEN
3466 YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
3467 YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
3468 ELSE
3469 YEFF1 = 1.D0+(1.D0-Y1)**2
3470 YEFF2 = 1.D0+(1.D0-Y2)**2
3471 ENDIF
3472
3473 Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
3474 Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
3475 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
3476 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
3477 WGH = (YEFF1*Q2LOG1
3478 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3479 & *(YEFF2*Q2LOG2
3480 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3481 IF(WGMAX.LT.WGH) THEN
3482 WRITE(LO,'(1X,A,4E12.5)')
3483 & 'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
3484 ENDIF
3485 IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
3486
3487C limit on Ecm_gg (app. cut, precise cut applied later)
3488 GGECM2 = 4.D0*Y1*Y2*EE1*EE2
3489 if(GGECM2.lt.ECMIN2) goto 175
3490
3491C sample Q2
3492 IF(IPAMDL(174).EQ.1) THEN
3493 185 CONTINUE
3494 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
3495 WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
3496 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
3497 ELSE
3498 Q2P1 = Q2LOW1
3499 ENDIF
3500
3501 IF(IPAMDL(174).EQ.1) THEN
3502 186 CONTINUE
3503 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
3504 WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
3505 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
3506 ELSE
3507 Q2P2 = Q2LOW2
3508 ENDIF
3509
3510 GYY(1) = Y1
3511 GQ2(1) = Q2P1
3512 GYY(2) = Y2
3513 GQ2(2) = Q2P2
3514
3515C incoming electron 1
3516 PINI(1,1) = 0.D0
3517 PINI(2,1) = 0.D0
3518 PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
3519 PINI(4,1) = EE1
3520 PINI(5,1) = ELEM
3521C photon 1
3522 PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
3523 PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
3524 & -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
3525 IF(PT2.LT.0.D0) GOTO 175
3526 PT = SQRT(PT2)
3527 CALL PHO_SFECFE(SIF1,COF1)
3528 P1(1) = COF1*PT
3529 P1(2) = SIF1*PT
3530 P1(3) = PP
3531 P1(4) = EE1*Y1
3532C outgoing electron 1
3533 PFIN(1,1) = -P1(1)
3534 PFIN(2,1) = -P1(2)
3535 PFIN(3,1) = PINI(3,1)-P1(3)
3536 PFIN(4,1) = PINI(4,1)-P1(4)
3537 PFIN(5,1) = ELEM
3538C incoming electron 2
3539 PINI(1,2) = 0.D0
3540 PINI(2,2) = 0.D0
3541 PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
3542 PINI(4,2) = EE2
3543 PINI(5,2) = 0.D0
3544C photon 2
3545 PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
3546 PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
3547 & -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
3548 IF(PT2.LT.0.D0) GOTO 175
3549 PT = SQRT(PT2)
3550 CALL PHO_SFECFE(SIF2,COF2)
3551 P2(1) = COF2*PT
3552 P2(2) = SIF2*PT
3553 P2(3) = PP
3554 P2(4) = EE2*Y2
3555C outgoing electron 2
3556 PFIN(1,2) = -P2(1)
3557 PFIN(2,2) = -P2(2)
3558 PFIN(3,2) = PINI(3,2)-P2(3)
3559 PFIN(4,2) = PINI(4,2)-P2(4)
3560 PFIN(5,2) = ELEM
3561
3562C precise ECMS cut
3563
3564 GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3565 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3566 IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
3567 GGECM = SQRT(GGECM2)
3568
3569C beam lepton detector acceptance
3570
3571C lepton tagger 1
3572 CPFTHE = PFIN(3,1)/PFIN(4,1)
3573 ITG1 = 0
3574 IF(PFIN(4,1).GE.EEMIN1) THEN
3575 IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
3576 ENDIF
3577
3578C lepton tagger 2
3579 CPFTHE = PFIN(3,2)/PFIN(4,2)
3580 ITG2 = 0
3581 IF(PFIN(4,2).GE.EEMIN2) THEN
3582 IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
3583 ENDIF
3584
3585C beam lepton taggers
3586
3587C anti-tag
3588 IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
3589 IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
3590C tag
3591 IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
3592 IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
3593C single-tag inclusive
3594 IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
3595 & GOTO 175
3596C single-tag/anti-tag
3597 IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
3598 & GOTO 175
3599
3600 PGAM(1,1) = P1(1)
3601 PGAM(2,1) = P1(2)
3602 PGAM(3,1) = P1(3)
3603 PGAM(4,1) = P1(4)
3604 PGAM(5,1) = -SQRT(Q2P1)
3605 PGAM(1,2) = P2(1)
3606 PGAM(2,2) = P2(2)
3607 PGAM(3,2) = P2(3)
3608 PGAM(4,2) = P2(4)
3609 PGAM(5,2) = -SQRT(Q2P2)
3610
3611C photon helicities
3612 IF(ISWMDL(10).GE.2) THEN
3613 WGH = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
3614 WGHL = 2.D0*(1-Y1)
3615 IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
3616 IGHEL(1) = 1
3617 ELSE
3618 IGHEL(1) = 0
3619 ENDIF
3620 WGH = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
3621 WGHL = 2.D0*(1-Y2)
3622 IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
3623 IGHEL(2) = 1
3624 ELSE
3625 IGHEL(2) = 0
3626 ENDIF
3627 K = 2*IGHEL(1)+IGHEL(2)+1
3628 IHETRY(K) = IHETRY(K)+1
3629 ELSE
3630 IGHEL(1) = -1
3631 IGHEL(2) = -1
3632 ENDIF
3633
3634C user cuts
3635 CALL PHO_PRESEL(5,IREJ)
3636 IF(IREJ.NE.0) GOTO 175
3637
3638 WGFX = 1.D0
3639C reweight according to LO photon emission diagrams (Budnev et al.)
3640 IF(IPAMDL(116).GE.1) THEN
3641 CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
3642 WGFX = FLXQPM/FLXAPP
3643 if(WGFX.gt.1.D0) then
3644 WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
3645 & ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
3646 & Y1,Y2,Q2P1,Q2P2,GGECM
3647 endif
3648 ENDIF
3649
3650C event generation
3651* IVWGHT(1) = 1
3652* EVWGHT(1) = MAX(WGFX,1.D0)
3653 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3654 IF(IREJ.NE.0) GOTO 150
3655 IF(ISWMDL(10).GE.2) THEN
3656 K = 2*IGHEL(1)+IGHEL(2)+1
3657 IHEAC1(K) = IHEAC1(K)+1
3658 ENDIF
3659
3660C reweight according to QPM model (e+e- collider only)
3661 IF((KHDIR.GT.0).AND.
3662 & (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
3663 CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
3664 WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
3665 IF(DT_RNDM(WG).GT.WG) GOTO 150
3666 ELSE IF(IPAMDL(116).GE.1) THEN
3667 IF(DT_RNDM(WG).GT.WGFX) GOTO 150
3668 ENDIF
3669
3670C polar angle
3671 PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
3672 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3673C azimuthal angle
3674 PFPHI(1) = ATAN2(COF1,SIF1)
3675 PFPHI(2) = ATAN2(COF2,SIF2)
3676
3677C statistics
3678 AY1 = AY1+Y1
3679 AYS1 = AYS1+Y1*Y1
3680 AY2 = AY2+Y2
3681 AYS2 = AYS2+Y2*Y2
3682 Q21MIN = MIN(Q21MIN,Q2P1)
3683 Q22MIN = MIN(Q22MIN,Q2P2)
3684 Q21MAX = MAX(Q21MAX,Q2P1)
3685 Q22MAX = MAX(Q22MAX,Q2P2)
3686 AN1MIN = MIN(AN1MIN,PFTHE(1))
3687 AN2MIN = MIN(AN2MIN,PFTHE(2))
3688 AN1MAX = MAX(AN1MAX,PFTHE(1))
3689 AN2MAX = MAX(AN2MAX,PFTHE(2))
3690 YY1MIN = MIN(YY1MIN,Y1)
3691 YY2MIN = MIN(YY2MIN,Y2)
3692 YY1MAX = MAX(YY1MAX,Y1)
3693 YY2MAX = MAX(YY2MAX,Y2)
3694 Q21AVE = Q21AVE+Q2P1
3695 Q22AVE = Q22AVE+Q2P2
3696 Q21AV2 = Q21AV2+Q2P1*Q2P1
3697 Q22AV2 = Q22AV2+Q2P2*Q2P2
3698 IF(ISWMDL(10).GE.2) THEN
3699 K = 2*IGHEL(1)+IGHEL(2)+1
3700 IHEAC2(K) = IHEAC2(K)+1
3701 ENDIF
3702
3703C external histograms
3704 CALL PHO_PHIST(1,HSWGHT(0))
3705 CALL PHO_LHIST(1,HSWGHT(0))
3706 200 CONTINUE
3707
3708C final cross section calculation and event generation summary
3709
3710 else if(NEVENT.eq.-2) then
3711
3712* EVWGHT(1) = 1.D0
3713* IVWGHT(1) = 0
3714 DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
3715 DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
3716 WGY = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
3717 WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
3718 AY1 = AY1/DBLE(NITER)
3719 AYS1 = AYS1/DBLE(NITER)
3720 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
3721 AY2 = AY2/DBLE(NITER)
3722 AYS2 = AYS2/DBLE(NITER)
3723 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
3724 Q21AVE = Q21AVE/DBLE(NITER)
3725 Q21AV2 = Q21AV2/DBLE(NITER)
3726 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
3727 Q22AVE = Q22AVE/DBLE(NITER)
3728 Q22AV2 = Q22AV2/DBLE(NITER)
3729 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3730 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
3731 EE1 = WEIGHT
3732 EE2 = SIGMAX*DBLE(NITER)/DITRY
3733
3734C output of statistics, histograms
3735 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3736 & '=========================================================',
3737 & ' ***** simulated cross section: ',WEIGHT,' mb *****',
3738 & '========================================================='
3739 WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
3740 & 'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
3741 WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
3742 & WGY,WEIGHT
3743 WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1 ',
3744 & AY1,DAY1
3745 WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2 ',
3746 & AY2,DAY2
3747 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1 ',
3748 & YY1MIN,YY1MAX
3749 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2 ',
3750 & YY2MIN,YY2MAX
3751 WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1 ',
3752 & Q21AVE,Q21AV2
3753 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1 ',
3754 & Q21MIN,Q21MAX
3755 WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 2 ',
3756 & Q22AVE,Q22AV2
3757 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2 ',
3758 & Q22MIN,Q22MAX
3759 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
3760 & AN1MIN,AN1MAX
3761 WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
3762 & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3763
3764 IF(ISWMDL(10).GE.2) THEN
3765 WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
3766 & 'Helicity decomposition: 0 0 0 1 1 0 1 1',
3767 & 'tried: ',IHETRY,
3768 & 'accepted (1): ',IHEAC1,
3769 & 'accepted (2): ',IHEAC2
3770 ENDIF
3771
3772 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3773 IF(NITER.GT.1) THEN
3774 CALL PHO_PHIST(-2,WEIGHT)
3775 CALL PHO_LHIST(-2,WEIGHT)
3776 ELSE
3777 WRITE(LO,'(1X,A,I4)')
3778 & 'PHO_GGEPEM: no output of histograms',NITER
3779 ENDIF
3780
3781 endif
3782
3783 END
3784
3785*$ CREATE PHO_WGEPEM.FOR
3786*COPY PHO_WGEPEM
3787CDECK ID>, PHO_WGEPEM
3788 SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
3789C**********************************************************************
3790C
3791C calculate cross section weights for
3792C fully differential equivalent (improved) photon approximation
3793C and/or
3794C fully differential QPM model with exact one-photon exchange graphs
3795C
3796C (unpolarized lepton beams)
3797C
3798C input: IMODE 0 flux calculation only
3799C 1 flux folded with QPM cross section
3800C /POFSRC/ photon and electron momenta
3801C /POPRCS/ process type
3802C /POCKIN/ kinematics of hard scattering
3803C
3804C output: WGHAPP weight of event according to approximation
3805C WGHQPM weight of event according to one-photon exchange
3806C
3807C**********************************************************************
3808
3809 IMPLICIT NONE
3810
3811 SAVE
3812
3813 DOUBLE PRECISION WGHAPP,WGHQPM
3814 INTEGER IMODE
3815
3816C input/output channels
3817 INTEGER LI,LO
3818 COMMON /POINOU/ LI,LO
3819C event debugging information
3820 INTEGER NMAXD
3821 PARAMETER (NMAXD=100)
3822 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3823 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3824 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3825 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3826C model switches and parameters
3827 CHARACTER*8 MDLNA
3828 INTEGER ISWMDL,IPAMDL
3829 DOUBLE PRECISION PARMDL
3830 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3831C some constants
3832 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3833 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3834 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3835C gamma-lepton or gamma-hadron vertex information
3836 INTEGER IGHEL,IDPSRC,IDBSRC
3837 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3838 & RADSRC,AMSRC,GAMSRC
3839 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3840 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3841 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3842C general process information
3843 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3844 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3845C data on most recent hard scattering
3846 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3847 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3848 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
3849 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
3850 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3851 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
3852 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
3853 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
3854 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3855C hard scattering parameters used for most recent hard interaction
3856 INTEGER NFbeta,NF
3857 DOUBLE PRECISION ALQCD2,BQCD
3858 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
3859C currently activated parton density parametrizations
3860 CHARACTER*8 PDFNAM
3861 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
3862 DOUBLE PRECISION PDFLAM,PDFQ2M
3863 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
3864 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
3865
3866C standard particle data interface
3867 INTEGER NMXHEP
3868
3869 PARAMETER (NMXHEP=4000)
3870
3871 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
3872 DOUBLE PRECISION PHEP,VHEP
3873 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
3874 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
3875 & VHEP(4,NMXHEP)
3876C extension to standard particle data interface (PHOJET specific)
3877 INTEGER IMPART,IPHIST,ICOLOR
3878 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
3879
3880 DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
3881 & P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
3882 & RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
3883 & SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
3884 & TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
3885 & XM2,XQ2,XTM1,XTM2,XTM3,YCAP
3886 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
3887
3888 INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
3889
3890 DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
3891 DIMENSION HELFLX(6),SIGQPM(6)
3892
3893 WGHAPP = 1.D0
3894 WGHQPM = 0.D0
3895
3896C strict pt cutoff after putting partons on mass shell,
3897C calculated in gamma-gamma CMS
3898 if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
3899 if(PTfin.lt.PTwant) then
3900 if(ipamdl(121).gt.1) return
3901 if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
3902 endif
3903 endif
3904
3905C cross section of sampled event (approximate treatment)
3906
3907C photon flux
3908 DO 50 K=1,2
3909 XM2(K) = AMSRC(K)**2
3910 IF(abs(IGHEL(K)).EQ.1) THEN
3911 WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
3912 & -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
3913 ELSE
3914 WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
3915 ENDIF
3916 50 CONTINUE
3917
3918 W2 = GGECM*GGECM
3919 IDIR = 0
3920 WGHQQ = 1.D0
3921
3922C direct or single-resolved gam-gam interaction
3923 IF((IMODE.GE.1).AND.
3924 & (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
3925 IDIR = 1
3926 WGHQQ = 0.D0
3927C determine final state partons
3928 DO 100 I=3,NHEP
3929 IF(ISTHEP(I).EQ.25) GOTO 110
3930 100 CONTINUE
3931 WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
3932 & 'inconsistent process information (MSPR)',MSPR
3933 CALL PHO_ABORT
3934 110 CONTINUE
3935 IPOS = I
3936C final state flavors
3937 IPFL1 = ABS(IDHEP(IPOS+3))
3938 IPFL2 = ABS(IDHEP(IPOS+4))
3939 SH = X1*X2*W2
3940C calculate alpha-em
3941 ALPHA1 = pho_alphae(QQAL)
3942C calculate alpha-s
3943 IF(MSPR.LT.14) THEN
3944 ALPHA2 = PHO_ALPHAS(QQAL,3)
3945 ENDIF
3946C LO matrix element (8 pi s dsig/dt)
3947* QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
3948 QC2 = Q_ch2(IPFL2)
3949 IF(IPFL2.EQ.0) THEN
3950 WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
3951 & 'invalid hard process - flavor combination',
3952 & 'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
3953 ENDIF
3954 IF(MSPR.EQ.10) THEN
3955 WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
3956 & *8.D0*PI*SH
3957 ELSE IF(MSPR.EQ.11) THEN
3958 WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3959 & *8.D0*PI*SH
3960 ELSE IF(MSPR.EQ.12) THEN
3961 WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
3962 & *8.D0*PI*SH
3963 ELSE IF(MSPR.EQ.13) THEN
3964 WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3965 & *8.D0*PI*SH
3966 ELSE IF(MSPR.EQ.14) THEN
3967 WGHQQ = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
3968 & *8.D0*PI*SH
3969 ENDIF
3970 ENDIF
3971
3972C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3973 WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
3974
3975C full leading-order QPM prediction (Budnev et al.)
3976
3977C full two-gamma flux
3978
3979 P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
3980 & -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
3981 P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
3982 & -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
3983 Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
3984 & -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
3985 P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
3986 & -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
3987 DO 120 I=1,4
3988 P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
3989 P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
3990 120 CONTINUE
3991 XTM1 = 2.D0*P1Q2-Q1Q2
3992 XTM2 = 2.D0*P2Q1-Q1Q2
3993 XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
3994 XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
3995 YCAP = P1P2**2-XM2(1)*XM2(2)
3996 CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
3997
3998 RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
3999 RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
4000 RHO100 = XTM1**2/XCAP-1.D0
4001 RHO200 = XTM2**2/XCAP-1.D0
4002 RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
4003 RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
4004 SS = 2.D0*P1P2+XM2(1)+XM2(2)
4005
4006 HELFLX(1) = 4.D0*RHO1PP*RHO2PP
4007 HELFLX(2) = RHOPM2
4008 HELFLX(3) = 2.D0*RHO1PP*RHO200
4009 HELFLX(4) = 2.D0*RHO100*RHO2PP
4010 HELFLX(5) = RHO100*RHO200
4011 HELFLX(6) = -RHOP08
4012
4013C only flux calculation
4014
4015 IF(IDIR.EQ.0) THEN
4016 IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4017 WEIGHT = HELFLX(1)
4018 ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4019 WEIGHT = HELFLX(3)
4020 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4021 WEIGHT = HELFLX(4)
4022 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4023 WEIGHT = HELFLX(5)
4024 ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
4025 WEIGHT = HELFLX(1)
4026 ELSE
4027 WRITE(LO,'(/1X,A,2I3)')
4028 & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4029 WRITE(LO,'(1X,A,I12)')
4030 & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4031 WEIGHT = 0.D0
4032 ENDIF
4033
4034C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4035 WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4036 & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4037
4038 ELSE
4039
4040C flux folded with cross section
4041C polarized, leading order gam gam --> q qbar cross sections
4042
4043 DO 125 I=1,6
4044 SIGQPM(I) = 0.D0
4045 125 CONTINUE
4046C momenta of produced parton pair
4047 I1 = IPOS+3
4048 I2 = IPOS+4
4049 DO 150 K=1,4
4050 XK1(K) = PHEP(K,I1)
4051 XK2(K) = PHEP(K,I2)
4052 150 CONTINUE
4053 XQ2 = PHEP(5,I2)**2
4054
4055 IF(MSPR.EQ.14) THEN
4056C direct photon-photon interaction
4057 XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
4058 & +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
4059 & +(PGAM(3,1)-XK1(3))**2
4060 XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
4061 & +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
4062 & +(PGAM(3,1)-XK2(3))**2
4063 CC = Q1Q2
4064 AA = XKAP*XKAM-GQ2(1)*GQ2(2)
4065 BB = CC**2-XKAP*XKAM
4066 DD = CC**2-GQ2(1)*GQ2(2)
4067 RR = -XQ2+W2*AA/(4.D0*DD)
4068 Q1KK = Q1Q2-GQ2(1)
4069 Q2KK = Q1Q2-GQ2(2)
4070 FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
4071
4072 ELSE
4073C single-resolved photon-hadron interactions
4074C Mandelstam variables
4075 IF(MSPR.LE.11) THEN
4076 TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
4077 & -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
4078 UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
4079 & -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
4080 ELSE
4081 TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
4082 & -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
4083 UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
4084 & -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
4085 ENDIF
4086 V = TH/SH
4087 U = UH/SH
4088 ENDIF
4089
4090 WEIGHT = 0.D0
4091 IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4092 IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
4093 IF(MSPR.EQ.10) THEN
4094 Q2 = -GQ2(1)
4095 SP = SH-XQ2
4096 TP = UH-XQ2
4097 ELSE
4098 Q2 = -GQ2(2)
4099 SP = SH-XQ2
4100 TP = TH-XQ2
4101 ENDIF
4102 SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
4103 & *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
4104 & +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
4105 & -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
4106 & -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
4107 & (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
4108 & 4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
4109 & (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
4110 WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4111 ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
4112 IF(MSPR.EQ.11) THEN
4113 Q2 = -GQ2(1)
4114 ELSE
4115 Q2 = -GQ2(2)
4116 ENDIF
4117 SP = SH
4118 TP = UH
4119 SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
4120 & *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
4121 & - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
4122 & (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
4123 & (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
4124 & 4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
4125 & +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
4126 & *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
4127 & SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
4128 & (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
4129 & *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
4130 & +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
4131 & *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
4132 & 2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
4133 & (Q2-SP-TP+XQ2)**2)
4134 WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4135 ELSE IF(MSPR.EQ.14) THEN
4136 SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
4137 SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
4138 SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
4139 & -2.D0*XKAP*XKAM*AA
4140 SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
4141 SIGQPM(2) = SWPPMM*FAC
4142 WEIGHT = HELFLX(1)*SIGQPM(1)
4143 & +HELFLX(2)*SIGQPM(2)
4144 ENDIF
4145 ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4146 IF(MSPR.EQ.12) THEN
4147 Q2 = -GQ2(2)
4148 SP = SH-XQ2
4149 TP = TH-XQ2
4150 SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4151 & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4152 & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4153 & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4154 & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4155 & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4156 & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4157 & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4158 WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4159 ELSE IF(MSPR.EQ.13) THEN
4160 Q2 = -GQ2(2)
4161 SP = SH
4162 TP = TH
4163 SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4164 & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4165 & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4166 WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4167 ELSE IF(MSPR.EQ.14) THEN
4168 SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
4169 & -XKAP*XKAM*Q1KK**2)/DD
4170 SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
4171 SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4172 & *SQRT(GQ2(1)*GQ2(2))/DD
4173 SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4174 & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4175 SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4176 & *SQRT(GQ2(1)*GQ2(2))/DD
4177 SIGQPM(3) = SWP0P0*FAC
4178 SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4179 WEIGHT = HELFLX(3)*SIGQPM(3)
4180 & +HELFLX(6)*SIGQPM(6)/2.D0
4181 ENDIF
4182 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4183 IF(MSPR.EQ.10) THEN
4184 Q2 = -GQ2(1)
4185 SP = SH-XQ2
4186 TP = UH-XQ2
4187 SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4188 & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4189 & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4190 & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4191 & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4192 & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4193 & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4194 & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4195 WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
4196 ELSE IF(MSPR.EQ.11) THEN
4197 Q2 = -GQ2(1)
4198 SP = SH
4199 TP = TH
4200 SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4201 & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4202 & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4203 WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
4204 ELSE IF(MSPR.EQ.14) THEN
4205 SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
4206 & -XKAP*XKAM*Q2KK**2)/DD
4207 SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
4208 SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4209 & *SQRT(GQ2(1)*GQ2(2))/DD
4210 SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4211 & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4212 SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4213 & *SQRT(GQ2(1)*GQ2(2))/DD
4214 SIGQPM(4) = SW0P0P*FAC
4215 SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4216 WEIGHT = HELFLX(4)*SIGQPM(4)
4217 & +HELFLX(6)*SIGQPM(6)/2.D0
4218 ENDIF
4219 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4220 IF(MSPR.EQ.14) THEN
4221 SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
4222 SIGQPM(5) = SW0000*FAC
4223 WEIGHT = HELFLX(5)*SIGQPM(5)
4224 ENDIF
4225 ELSE
4226 WRITE(LO,'(/1X,A,2I3)')
4227 & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4228 WRITE(LO,'(1X,A,I12)')
4229 & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4230 WEIGHT = 0.D0
4231 ENDIF
4232
4233C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4234
4235 WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4236 & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4237
4238 ENDIF
4239
4240 END
4241
4242*$ CREATE PHO_GGBLSR.FOR
4243*COPY PHO_GGBLSR
4244CDECK ID>, PHO_GGBLSR
4245 SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
4246 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
4247C***********************************************************************
4248C
4249C interface to call PHOJET (variable energy run) for
4250C gamma-gamma collisions via laser backscattering
4251C
4252C input: EE1 lab. system energy of electron/positron 1
4253C EE2 lab. system energy of electron/positron 2
4254C NEVENT number of events to generate
4255C Pl_lam_1/2 product of electron and photon pol.
4256C X_1/2 standard X parameter
4257C rho ratio of distance to conversion point and
4258C transverse beam size
4259C A ellipticity of electon beam
4260C
4261C (see Ginzburg & Kotkin hep-ph/9905462)
4262C
4263C from /LEPCUT/:
4264C YMIN1 lower limit of Y1
4265C (energy fraction taken by photon from electron)
4266C YMAX1 upper limit of Y1
4267C YMIN2 lower limit of Y2
4268C (energy fraction taken by photon from electron)
4269C YMAX2 upper limit of Y2
4270C
4271C***********************************************************************
4272 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4273 SAVE
4274
4275 PARAMETER ( PI = 3.14159265359D0 )
4276
4277C input/output channels
4278 INTEGER LI,LO
4279 COMMON /POINOU/ LI,LO
4280C event debugging information
4281 INTEGER NMAXD
4282 PARAMETER (NMAXD=100)
4283 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4284 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4285 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4286 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4287C photon flux kinematics and cuts
4288 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4289 & YMIN1,YMAX1,YMIN2,YMAX2,
4290 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4291 & THMIN1,THMAX1,THMIN2,THMAX2
4292 INTEGER ITAG1,ITAG2
4293 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4294 & YMIN1,YMAX1,YMIN2,YMAX2,
4295 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4296 & THMIN1,THMAX1,THMIN2,THMAX2,
4297 & ITAG1,ITAG2
4298C gamma-lepton or gamma-hadron vertex information
4299 INTEGER IGHEL,IDPSRC,IDBSRC
4300 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4301 & RADSRC,AMSRC,GAMSRC
4302 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4303 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4304 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4305C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4306 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4307 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4308 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4309 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4310C event weights and generated cross section
4311 INTEGER IPOWGC,ISWCUT,IVWGHT
4312 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4313 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4314 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4315
4316 parameter (N_dim=100)
4317 dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
4318 & X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
4319 & Xgrid(96),Wgrid(96)
4320
4321 DIMENSION P1(4),P2(4)
4322
4323 Pi2 = 2.D0*Pi
4324
4325 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
4326
4327 YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
4328 YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
4329 IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
4330 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
4331 & 'invalid Ymin1,Ymin2',YMIN1,YMIN2
4332 RETURN
4333 ENDIF
4334 IDPSRC(1) = 0
4335 IDBSRC(1) = 0
4336 IDPSRC(2) = 0
4337 IDBSRC(2) = 0
4338
4339C initialize sampling
4340
4341 Max_tab = 50
4342 DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
4343 DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
4344
4345 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4346 & 'PHO_GGBLSR: table of photon flux ',Max_tab
4347
4348 DO 100 I=1,Max_tab
4349
4350 y1 = YMIN1+DELY1*DBLE(I-1)
4351 r1 = y1/(X_1*(1.D0-y1))
4352 X_inp_1(i) = y1
4353 F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
4354 & -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
4355
4356 y2 = YMIN2+DELY2*DBLE(I-1)
4357 r2 = y2/(X_2*(1.D0-y2))
4358 X_inp_2(i) = y2
4359 F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
4360 & -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
4361
4362 IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
4363 & y1,F_inp_1(i),y2,F_inp_2(i)
4364
4365 100 CONTINUE
4366
4367 call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4368 call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4369
4370C initialize event generator
4371
4372C photon 1
4373 EGAM = YMAX1*EE1
4374 P1(1) = 0.D0
4375 P1(2) = 0.D0
4376 P1(3) = EGAM
4377 P1(4) = EGAM
4378C photon 2
4379 EGAM = YMAX2*EE2
4380 P2(1) = 0.D0
4381 P2(2) = 0.D0
4382 P2(3) = -EGAM
4383 P2(4) = EGAM
4384 CALL PHO_SETPAR(1,22,0,0.D0)
4385 CALL PHO_SETPAR(2,22,0,0.D0)
4386 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4387 CALL PHO_PHIST(-1,SIGMAX)
4388 CALL PHO_LHIST(-1,SIGMAX)
4389
4390C generation of events
4391
4392 AY1 = 0.D0
4393 AY2 = 0.D0
4394 AYS1 = 0.D0
4395 AYS2 = 0.D0
4396 NITER = NEVENT
4397 ITRY = 0
4398 ITRW = 0
4399 DO 200 I=1,NITER
4400 150 CONTINUE
4401 ITRY = ITRY+1
4402 175 CONTINUE
4403 ITRW = ITRW+1
4404
4405 call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4406 call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4407
4408 g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
4409 g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
4410 if(abs(1.D0-A).lt.1.D-3) then
4411 v = rho**2/4.D0*g_1*g_2
4412 Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
4413 else
4414 Nint = 16
4415 call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
4416 A2 = A**2
4417 fac = rho**2/(4.D0*(1.D0+A2))
4418 Wght = 0.D0
4419 do i1=1,Nint
4420 phi_1 = Xgrid(i1)
4421 do i2=1,Nint
4422 phi_2 = Xgrid(i2)
4423 Wght = Wght
4424 & +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
4425 & +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
4426 & *Wgrid(i1)*Wgrid(i2)
4427 enddo
4428 enddo
4429 Wght = Wght/Pi2**2
4430 endif
4431
4432 IF(Wght.GT.1.D0) THEN
4433 WRITE(LO,'(1X,A,5E11.4)')
4434 & 'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
4435 ENDIF
4436 IF(DT_RNDM(dum).GT.Wght) GOTO 175
4437
4438 Y1 = X_out_1
4439 Y2 = X_out_2
4440
4441 Q2P1 = 0.D0
4442 Q2P2 = 0.D0
4443 GYY(1) = Y1
4444 GQ2(1) = Q2P1
4445 GYY(2) = Y2
4446 GQ2(2) = Q2P2
4447C incoming electron 1
4448 PINI(1,1) = 0.D0
4449 PINI(2,1) = 0.D0
4450 PINI(3,1) = EE1
4451 PINI(4,1) = EE1
4452 PINI(5,1) = 0.D0
4453C outgoing electron 1
4454 YQ2 = SQRT((1.D0-Y1)*Q2P2)
4455 Q2E = Q2P1/(4.D0*EE1)
4456 E1Y = EE1*(1.D0-Y1)
4457 CALL PHO_SFECFE(SIF,COF)
4458 PFIN(1,1) = YQ2*COF
4459 PFIN(2,1) = YQ2*SIF
4460 PFIN(3,1) = E1Y-Q2E
4461 PFIN(4,1) = E1Y+Q2E
4462 PFIN(5,1) = 0.D0
4463C photon 1
4464 P1(1) = -PFIN(1,1)
4465 P1(2) = -PFIN(2,1)
4466 P1(3) = PINI(3,1)-PFIN(3,1)
4467 P1(4) = PINI(4,1)-PFIN(4,1)
4468C incoming electron 2
4469 PINI(1,2) = 0.D0
4470 PINI(2,2) = 0.D0
4471 PINI(3,2) = -EE2
4472 PINI(4,2) = EE2
4473 PINI(5,2) = 0.D0
4474C outgoing electron 2
4475 YQ2 = SQRT((1.D0-Y2)*Q2P2)
4476 Q2E = Q2P2/(4.D0*EE2)
4477 E1Y = EE2*(1.D0-Y2)
4478 CALL PHO_SFECFE(SIF,COF)
4479 PFIN(1,2) = YQ2*COF
4480 PFIN(2,2) = YQ2*SIF
4481 PFIN(3,2) = -E1Y+Q2E
4482 PFIN(4,2) = E1Y+Q2E
4483 PFIN(5,2) = 0.D0
4484C photon 2
4485 P2(1) = -PFIN(1,2)
4486 P2(2) = -PFIN(2,2)
4487 P2(3) = PINI(3,2)-PFIN(3,2)
4488 P2(4) = PINI(4,2)-PFIN(4,2)
4489C ECMS cut
4490 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4491 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4492 IF(GGECM.LT.0.1D0) GOTO 175
4493 GGECM = SQRT(GGECM)
4494 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4495
4496 PGAM(1,1) = P1(1)
4497 PGAM(2,1) = P1(2)
4498 PGAM(3,1) = P1(3)
4499 PGAM(4,1) = P1(4)
4500 PGAM(5,1) = 0.D0
4501 PGAM(1,2) = P2(1)
4502 PGAM(2,2) = P2(2)
4503 PGAM(3,2) = P2(3)
4504 PGAM(4,2) = P2(4)
4505 PGAM(5,2) = 0.D0
4506C photon helicities
4507 IGHEL(1) = 1
4508 IGHEL(2) = 1
4509C cut given by user
4510 CALL PHO_PRESEL(5,IREJ)
4511 IF(IREJ.NE.0) GOTO 175
4512C event generation
4513 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4514 IF(IREJ.NE.0) GOTO 150
4515
4516C statistics
4517 AY1 = AY1+Y1
4518 AYS1 = AYS1+Y1*Y1
4519 AY2 = AY2+Y2
4520 AYS2 = AYS2+Y2*Y2
4521C histograms
4522 CALL PHO_PHIST(1,HSWGHT(0))
4523 CALL PHO_LHIST(1,HSWGHT(0))
4524 200 CONTINUE
4525
4526 WGY = DBLE(ITRY)/DBLE(ITRW)
4527 AY1 = AY1/DBLE(NITER)
4528 AYS1 = AYS1/DBLE(NITER)
4529 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4530 AY2 = AY2/DBLE(NITER)
4531 AYS2 = AYS2/DBLE(NITER)
4532 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4533 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4534C output of statistics, histograms
4535 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4536 &'=========================================================',
4537 &' ***** simulated cross section: ',WEIGHT,' mb *****',
4538 &'========================================================='
4539 WRITE(LO,'(//1X,A,3I10)')
4540 & 'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
4541 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4542 & WGY,WEIGHT
4543 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
4544 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
4545
4546 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4547 IF(NITER.GT.1) THEN
4548 CALL PHO_PHIST(-2,WEIGHT)
4549 CALL PHO_LHIST(-2,WEIGHT)
4550 ELSE
4551 WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
4552 ENDIF
4553
4554 END
4555
4556*$ CREATE pho_samp1d.FOR
4557*COPY pho_samp1d
4558CDECK ID>, pho_samp1d
4559 SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
4560C***********************************************************************
4561C
4562C Monte Carlo sampling from arbitrary 1d distribution
4563C (linear interpolation to improve reproduction of initial function)
4564C
4565C input: Imode -1 initialization
4566C 1 sampling (after initialization)
4567C X_inp(N_dim) array with x values
4568C F_inp(N_dim) array with function values
4569C F_int(N_dim) array with integral
4570C
4571C output: X_out sampled value (Imode=1)
4572C
4573C (R.E. 10/99)
4574C
4575C***********************************************************************
4576 implicit none
4577 save
4578
4579C input/output channels
4580 INTEGER LI,LO
4581 COMMON /POINOU/ LI,LO
4582
4583 integer Imode,N_dim
4584 double precision X_inp,F_inp,F_int,X_out
4585 dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
4586
4587C local variables
4588 integer i
4589 double precision dum,xi,a,b
4590
4591C external functions
4592 double precision DT_RNDM
4593 external DT_RNDM
4594
4595 if(Imode.eq.-1) then
4596
4597C initialization
4598
4599 F_int(1) = 0.D0
4600 do i=2,N_dim
4601 F_int(i) = F_int(i-1)
4602 & +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
4603 enddo
4604
4605 else if(Imode.eq.1) then
4606
4607C sample from previously calculated integral
4608
4609 xi = DT_RNDM(dum)*F_int(N_dim)
4610
4611 do i=2,N_dim
4612 if(xi.lt.F_int(i)) then
4613 a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
4614 b = F_inp(i)-a*X_inp(i)
4615 xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
4616 X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
4617 return
4618 endif
4619 enddo
4620 X_out = X_inp(N_dim)
4621
4622 else
4623
4624C invalid option Imode
4625
4626 WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
4627 X_out = 0.D0
4628
4629 endif
4630
4631 END
4632
4633*$ CREATE pho_ExpBessI0.FOR
4634*COPY pho_ExpBessI0
4635CDECK ID>, pho_ExpBessI0
4636 DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
4637C**********************************************************************
4638C
4639C Bessel Function I0 times exponential function from neg. arg.
4640C (defined for pos. arguments only)
4641C
4642C**********************************************************************
4643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4644 SAVE
4645
4646 AX = ABS(X)
4647 IF (AX .LT. 3.75D0) THEN
4648 Y = (X/3.75D0)**2
4649 pho_ExpBessI0 =
4650 & (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
4651 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
4652 ELSE
4653 Y = 3.75D0/AX
4654 pho_ExpBessI0 =
4655 & (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
4656 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
4657 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
4658 & +Y*0.392377D-2))))))))
4659 ENDIF
4660
4661 END
4662
4663*$ CREATE PHO_GGBEAM.FOR
4664*COPY PHO_GGBEAM
4665CDECK ID>, PHO_GGBEAM
4666 SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
4667C**********************************************************************
4668C
4669C interface to call PHOJET (variable energy run) for
4670C gamma-gamma collisions via beamstrahlung
4671C
4672C input: EE LAB system energy of electron/positron
4673C YPSI beamstrahlung parameter
4674C SIGX,Y transverse bunch dimensions
4675C SIGZ longitudinal bunch dimension
4676C AEB number of electrons/positrons in a bunch
4677C NEVENT number of events to generate
4678C from /LEPCUT/:
4679C YMIN1 lower limit of Y
4680C (energy fraction taken by photon from electron)
4681C YMAX1 upper cutoff for Y, necessary to avoid
4682C underflows
4683C
4684C**********************************************************************
4685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4686 SAVE
4687
4688 PARAMETER ( DEPS = 1.D-20,
4689 & PI = 3.14159265359D0 )
4690
4691C input/output channels
4692 INTEGER LI,LO
4693 COMMON /POINOU/ LI,LO
4694C event debugging information
4695 INTEGER NMAXD
4696 PARAMETER (NMAXD=100)
4697 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4698 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4699 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4700 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4701C photon flux kinematics and cuts
4702 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4703 & YMIN1,YMAX1,YMIN2,YMAX2,
4704 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4705 & THMIN1,THMAX1,THMIN2,THMAX2
4706 INTEGER ITAG1,ITAG2
4707 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4708 & YMIN1,YMAX1,YMIN2,YMAX2,
4709 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4710 & THMIN1,THMAX1,THMIN2,THMAX2,
4711 & ITAG1,ITAG2
4712C gamma-lepton or gamma-hadron vertex information
4713 INTEGER IGHEL,IDPSRC,IDBSRC
4714 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4715 & RADSRC,AMSRC,GAMSRC
4716 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4717 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4718 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4719C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4720 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4721 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4722 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4723 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4724C event weights and generated cross section
4725 INTEGER IPOWGC,ISWCUT,IVWGHT
4726 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4727 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4728 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4729
4730 PARAMETER (Max_tab=100)
4731 DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
4732
4733C
4734 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
4735C electron data
4736 RE = 2.818D-12
4737 ELEM = 0.512D-03
4738 IDPSRC(1) = 0
4739 IDBSRC(1) = 0
4740 IDPSRC(2) = 0
4741 IDBSRC(2) = 0
4742C table of flux function, log interpolation
4743 IF(YPSI.LE.0.D0) THEN
4744 YPSI = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
4745 ENDIF
4746 WRITE(LO,'(/1X,A,E12.4)')
4747 & 'PHO_GGBEAM: beamstrahlung parameter:',YPSI
4748 WRITE(LO,'(/1X,A,2E12.4)')
4749 & 'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
4750 TT = 2.D0/3.D0
4751 OT = 1.D0/3.D0
4752C GAOT = DGAMMA(OT)
4753 GAOT = 2.6789385347D0
4754 AKAP = TT/YPSI
4755 WW = 1.D0/(6.D0*SQRT(AKAP))
4756 ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
4757 & *YPSI/SQRT(1.D0+YPSI**TT)
4758
4759 YMIN = YMIN1
4760 YMAX = MIN(YMAX1,0.9D0)
4761 TABCU(0) = 0.D0
4762 TABYL(0) = LOG(YMIN)
4763 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
4764 FLUX = 0.D0
4765 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4766 & 'PHO_GGBEAM: table of photon flux',Max_tab
4767 DO 100 I=1,Max_tab
4768 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
4769 GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
4770 FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
4771 & *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
4772 & +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
4773 TABCU(I) = TABCU(I-1)+FF*Y
4774 TABYL(I) = LOG(Y)
4775 FLUX = FLUX+Y*FF
4776 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
4777 100 CONTINUE
4778 FLUX = FLUX*DELLY
4779 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
4780 & 'PHO_GGBEAM: integrated flux (one side):',FLUX
4781
4782 EE1 = EE
4783 EE2 = EE
4784C photon 1
4785 EGAM = YMAX*EE
4786 P1(1) = 0.D0
4787 P1(2) = 0.D0
4788 P1(3) = EGAM
4789 P1(4) = EGAM
4790C photon 2
4791 EGAM = YMAX*EE
4792 P2(1) = 0.D0
4793 P2(2) = 0.D0
4794 P2(3) = -EGAM
4795 P2(4) = EGAM
4796 CALL PHO_SETPAR(1,22,0,0.D0)
4797 CALL PHO_SETPAR(2,22,0,0.D0)
4798 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4799 CALL PHO_PHIST(-1,SIGMAX)
4800 CALL PHO_LHIST(-1,SIGMAX)
4801
4802C generation of events
4803
4804 AY1 = 0.D0
4805 AY2 = 0.D0
4806 AYS1 = 0.D0
4807 AYS2 = 0.D0
4808 NITER = NEVENT
4809 ITRY = 0
4810 ITRW = 0
4811 DO 200 I=1,NITER
4812 150 CONTINUE
4813 ITRY = ITRY+1
4814 175 CONTINUE
4815 ITRW = ITRW+1
4816 XI = DT_RNDM(AY1)*TABCU(Max_tab)
4817 DO 110 K=1,Max_tab
4818 IF(TABCU(K).GE.XI) THEN
4819 Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4820 Y1 = EXP(Y1)
4821 GOTO 120
4822 ENDIF
4823 110 CONTINUE
4824 Y1 = YMAX
4825 120 CONTINUE
4826 XI = DT_RNDM(AY2)*TABCU(Max_tab)
4827 DO 130 K=1,Max_tab
4828 IF(TABCU(K).GE.XI) THEN
4829 Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4830 Y2 = EXP(Y2)
4831 GOTO 140
4832 ENDIF
4833 130 CONTINUE
4834 Y2 = YMAX
4835 140 CONTINUE
4836
4837 Q2P1 = 0.D0
4838 Q2P2 = 0.D0
4839 GYY(1) = Y1
4840 GQ2(1) = Q2P1
4841 GYY(2) = Y2
4842 GQ2(2) = Q2P2
4843C incoming electron 1
4844 PINI(1,1) = 0.D0
4845 PINI(2,1) = 0.D0
4846 PINI(3,1) = EE1
4847 PINI(4,1) = EE1
4848 PINI(5,1) = 0.D0
4849C outgoing electron 1
4850 YQ2 = SQRT((1.D0-Y1)*Q2P2)
4851 Q2E = Q2P1/(4.D0*EE1)
4852 E1Y = EE1*(1.D0-Y1)
4853 CALL PHO_SFECFE(SIF,COF)
4854 PFIN(1,1) = YQ2*COF
4855 PFIN(2,1) = YQ2*SIF
4856 PFIN(3,1) = E1Y-Q2E
4857 PFIN(4,1) = E1Y+Q2E
4858 PFIN(5,1) = 0.D0
4859C photon 1
4860 P1(1) = -PFIN(1,1)
4861 P1(2) = -PFIN(2,1)
4862 P1(3) = PINI(3,1)-PFIN(3,1)
4863 P1(4) = PINI(4,1)-PFIN(4,1)
4864C incoming electron 2
4865 PINI(1,2) = 0.D0
4866 PINI(2,2) = 0.D0
4867 PINI(3,2) = -EE2
4868 PINI(4,2) = EE2
4869 PINI(5,2) = 0.D0
4870C outgoing electron 2
4871 YQ2 = SQRT((1.D0-Y2)*Q2P2)
4872 Q2E = Q2P2/(4.D0*EE2)
4873 E1Y = EE2*(1.D0-Y2)
4874 CALL PHO_SFECFE(SIF,COF)
4875 PFIN(1,2) = YQ2*COF
4876 PFIN(2,2) = YQ2*SIF
4877 PFIN(3,2) = -E1Y+Q2E
4878 PFIN(4,2) = E1Y+Q2E
4879 PFIN(5,2) = 0.D0
4880C photon 2
4881 P2(1) = -PFIN(1,2)
4882 P2(2) = -PFIN(2,2)
4883 P2(3) = PINI(3,2)-PFIN(3,2)
4884 P2(4) = PINI(4,2)-PFIN(4,2)
4885C ECMS cut
4886 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4887 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4888 IF(GGECM.LT.0.1D0) GOTO 175
4889 GGECM = SQRT(GGECM)
4890 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4891C
4892 PGAM(1,1) = P1(1)
4893 PGAM(2,1) = P1(2)
4894 PGAM(3,1) = P1(3)
4895 PGAM(4,1) = P1(4)
4896 PGAM(5,1) = 0.D0
4897 PGAM(1,2) = P2(1)
4898 PGAM(2,2) = P2(2)
4899 PGAM(3,2) = P2(3)
4900 PGAM(4,2) = P2(4)
4901 PGAM(5,2) = 0.D0
4902C photon helicities
4903 IGHEL(1) = 1
4904 IGHEL(2) = 1
4905C cut given by user
4906 CALL PHO_PRESEL(5,IREJ)
4907 IF(IREJ.NE.0) GOTO 175
4908C event generation
4909 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4910 IF(IREJ.NE.0) GOTO 150
4911**sr leading tab removed
4912 GGECML = LOG(GGECM)
4913**
4914
4915C statistics
4916 AY1 = AY1+Y1
4917 AYS1 = AYS1+Y1*Y1
4918 AY2 = AY2+Y2
4919 AYS2 = AYS2+Y2*Y2
4920C histograms
4921 CALL PHO_PHIST(1,HSWGHT(0))
4922 CALL PHO_LHIST(1,HSWGHT(0))
4923 200 CONTINUE
4924C
4925 WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
4926 AY1 = AY1/DBLE(NITER)
4927 AYS1 = AYS1/DBLE(NITER)
4928 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4929 AY2 = AY2/DBLE(NITER)
4930 AYS2 = AYS2/DBLE(NITER)
4931 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4932 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4933C output of statistics, histograms
4934 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4935 &'=========================================================',
4936 &' ***** simulated cross section: ',WEIGHT,' mb *****',
4937 &'========================================================='
4938 WRITE(LO,'(//1X,A,2I10)')
4939 & 'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
4940 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4941 & WGY,WEIGHT
4942 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
4943 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
4944C
4945 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4946 IF(NITER.GT.1) THEN
4947 CALL PHO_PHIST(-2,WEIGHT)
4948 CALL PHO_LHIST(-2,WEIGHT)
4949 ELSE
4950 WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
4951 ENDIF
4952
4953 END
4954
4955*$ CREATE PHO_GGHIOF.FOR
4956*COPY PHO_GGHIOF
4957CDECK ID>, PHO_GGHIOF
4958 SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
4959C**********************************************************************
4960C
4961C interface to call PHOJET (variable energy run) for
4962C gamma-gamma collisions via heavy ions (form factor approach)
4963C
4964C input: EEN LAB system energy per nucleon
4965C NA atomic number of ion/hadron
4966C NZ charge number of ion/hadron
4967C NEVENT number of events to generate
4968C from /LEPCUT/:
4969C YMIN1,2 lower limit of Y
4970C (energy fraction taken by photon from hadron)
4971C YMAX1,2 upper cutoff for Y, necessary to avoid
4972C underflows
4973C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
4974C Q2MAX1,2 maximum Q**2 of photons (if necessary,
4975C corrected according size of hadron)
4976C
4977C currently implemented approximation similar to:
4978C E.Papageorgiu PhysLettB250(1990)155
4979C
4980C**********************************************************************
4981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4982 SAVE
4983
4984 PARAMETER ( PI = 3.14159265359D0 )
4985
4986C input/output channels
4987 INTEGER LI,LO
4988 COMMON /POINOU/ LI,LO
4989C model switches and parameters
4990 CHARACTER*8 MDLNA
4991 INTEGER ISWMDL,IPAMDL
4992 DOUBLE PRECISION PARMDL
4993 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4994C event debugging information
4995 INTEGER NMAXD
4996 PARAMETER (NMAXD=100)
4997 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4998 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4999 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5000 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5001C photon flux kinematics and cuts
5002 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5003 & YMIN1,YMAX1,YMIN2,YMAX2,
5004 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5005 & THMIN1,THMAX1,THMIN2,THMAX2
5006 INTEGER ITAG1,ITAG2
5007 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5008 & YMIN1,YMAX1,YMIN2,YMAX2,
5009 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5010 & THMIN1,THMAX1,THMIN2,THMAX2,
5011 & ITAG1,ITAG2
5012C gamma-lepton or gamma-hadron vertex information
5013 INTEGER IGHEL,IDPSRC,IDBSRC
5014 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5015 & RADSRC,AMSRC,GAMSRC
5016 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5017 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5018 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5019C nucleon-nucleus / nucleus-nucleus interface to DPMJET
5020 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5021 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5022 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5023 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5024C event weights and generated cross section
5025 INTEGER IPOWGC,ISWCUT,IVWGHT
5026 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5027 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5028 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5029
5030 DIMENSION P1(4),P2(4),BIMP(2,2)
5031
5032C
5033 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
5034 & '--------------------------------------'
5035C hadron size and mass
5036 FM2GEV = 5.07D0
5037 HIMASS = DBLE(NA)*0.938D0
5038 HIMA2 = HIMASS**2
5039 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5040 ALPHA = DBLE(NZ**2)/137.D0
5041C correct Q2MAX1,2 according to hadron size
5042 Q2MAXH = 2.D0/HIRADI**2
5043 Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
5044 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
5045 IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
5046 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
5047C total hadron / heavy ion energy
5048 EE = EEN*DBLE(NA)
5049 GAMMA = EE/HIMASS
5050C setup /POFSRC/
5051 GAMSRC(1) = GAMMA
5052 GAMSRC(2) = GAMMA
5053 RADSRC(1) = HIRADI
5054 RADSRC(2) = HIRADI
5055 AMSRC(1) = HIMASS
5056 AMSRC(1) = HIMASS
5057C kinematic limitations
5058 YMI = (ECMIN/(2.D0*EE))**2
5059 IF(YMIN1.LT.YMI) THEN
5060 WRITE(LO,'(/1X,A,2E12.5)')
5061 & 'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
5062 YMIN1 = YMI
5063 ELSE IF(YMIN1.GT.YMI) THEN
5064 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5065 & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5066 & ' INSTEAD OF',YMIN1
5067 ENDIF
5068 IF(YMIN2.LT.YMI) THEN
5069 WRITE(LO,'(/1X,A,2E12.5)')
5070 & 'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
5071 YMIN2 = YMI
5072 ELSE IF(YMIN2.GT.YMI) THEN
5073 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5074 & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5075 & ' INSTEAD OF',YMIN2
5076 ENDIF
5077C kinematic limitation
5078 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5079 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5080C debug output
5081 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
5082 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
5083 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
5084 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
5085 & Q2MAX1
5086 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
5087 & Q2MAX2
5088 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
5089 & YMAX1
5090 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
5091 & YMAX2
5092 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
5093 & 2.D0*EEN,2.D0*EE
5094 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
5095 IF(Q2LOW1.GE.Q2MAX1) THEN
5096 WRITE(LO,'(/1X,A,2E12.4)')
5097 & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
5098 CALL PHO_ABORT
5099 ENDIF
5100 IF(Q2LOW2.GE.Q2MAX2) THEN
5101 WRITE(LO,'(/1X,A,2E12.4)')
5102 & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
5103 CALL PHO_ABORT
5104 ENDIF
5105C hadron numbers set to 0
5106 IDPSRC(1) = 0
5107 IDPSRC(2) = 0
5108 IDBSRC(1) = 0
5109 IDBSRC(2) = 0
5110C
5111 Max_tab = 100
5112 YMAX = YMAX1
5113 YMIN = YMIN1
5114 XMAX = LOG(YMAX)
5115 XMIN = LOG(YMIN)
5116 XDEL = XMAX-XMIN
5117 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5118 DO 100 I=1,Max_tab
5119 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5120 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5121 IF(Q2LOW1.GE.Q2MAX1) THEN
5122 WRITE(LO,'(/1X,A,2E12.4)')
5123 & 'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
5124 YMAX1 = MIN(Y1,YMAX1)
5125 GOTO 101
5126 ENDIF
5127 100 CONTINUE
5128 101 CONTINUE
5129 YMAX = YMAX2
5130 YMIN = YMIN2
5131 XMAX = LOG(YMAX)
5132 XMIN = LOG(YMIN)
5133 XDEL = XMAX-XMIN
5134 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5135 DO 102 I=1,Max_tab
5136 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5137 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
5138 IF(Q2LOW2.GE.Q2MAX2) THEN
5139 WRITE(LO,'(/1X,A,2E12.4)')
5140 & 'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
5141 YMAX2 = MIN(Y1,YMAX2)
5142 GOTO 103
5143 ENDIF
5144 102 CONTINUE
5145 103 CONTINUE
5146 YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5147 IF(YMI.GT.YMIN1) THEN
5148 WRITE(LO,'(/1X,A,2E12.4)')
5149 & 'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
5150 YMIN1 = YMI
5151 ENDIF
5152 YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5153 IF(YMI.GT.YMIN2) THEN
5154 WRITE(LO,'(/1X,A,2E12.4)')
5155 & 'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
5156 YMIN2 = YMI
5157 ENDIF
5158C
5159 X1MAX = LOG(YMAX1)
5160 X1MIN = LOG(YMIN1)
5161 X1DEL = X1MAX-X1MIN
5162 X2MAX = LOG(YMAX2)
5163 X2MIN = LOG(YMIN2)
5164 X2DEL = X2MAX-X2MIN
5165 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
5166 FLUX = 0.D0
5167 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5168 & 'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
5169 DO 105 I=1,Max_tab
5170 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
5171 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5172 FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
5173 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
5174 FLUX = FLUX+Y1*FF
5175 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
5176 105 CONTINUE
5177 FLUX = FLUX*DELLY
5178 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5179 & 'PHO_GGHIOF: integrated flux (one side):',FLUX
5180C
5181 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5182 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5183 Y1 = YMIN1
5184 Y2 = YMIN2
5185 WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
5186 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5187 & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
5188 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5189C
5190C photon 1
5191 EGAM = YMAX1*EE
5192 P1(1) = 0.D0
5193 P1(2) = 0.D0
5194 P1(3) = EGAM
5195 P1(4) = EGAM
5196C photon 2
5197 EGAM = YMAX2*EE
5198 P2(1) = 0.D0
5199 P2(2) = 0.D0
5200 P2(3) = -EGAM
5201 P2(4) = EGAM
5202 CALL PHO_SETPAR(1,22,0,0.D0)
5203 CALL PHO_SETPAR(2,22,0,0.D0)
5204 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5205 CALL PHO_PHIST(-1,SIGMAX)
5206 CALL PHO_LHIST(-1,SIGMAX)
5207C
5208C generation of events, flux calculation
5209
5210 ECFRAC = ECMIN**2/(4.D0*EE*EE)
5211 AY1 = 0.D0
5212 AY2 = 0.D0
5213 AYS1 = 0.D0
5214 AYS2 = 0.D0
5215 Q21MIN = 1.D30
5216 Q22MIN = 1.D30
5217 Q21MAX = 0.D0
5218 Q22MAX = 0.D0
5219 Q21AVE = 0.D0
5220 Q22AVE = 0.D0
5221 Q21AV2 = 0.D0
5222 Q22AV2 = 0.D0
5223 YY1MIN = 1.D30
5224 YY2MIN = 1.D30
5225 YY1MAX = 0.D0
5226 YY2MAX = 0.D0
5227 NITER = NEVENT
5228 ITRY = 0
5229 ITRW = 0
5230 DO 200 I=1,NITER
5231C sample y1, y2
5232 150 CONTINUE
5233 ITRY = ITRY+1
5234 175 CONTINUE
5235 ITRW = ITRW+1
5236 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
5237 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
5238 IF(Y1*Y2.LT.ECFRAC) GOTO 175
5239C
5240 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
5241 IF(Q2LOW1.GE.Q2MAX1) GOTO 175
5242 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
5243 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
5244 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
5245 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
5246 WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
5247 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5248 & *((1.D0+(1.D0-Y2)**2)*Q2LOG2
5249 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5250 IF(WGMAX.LT.WGH) THEN
5251 WRITE(LO,'(1X,A,4E12.5)')
5252 & 'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
5253 ENDIF
5254 IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
5255C sample Q2
5256 IF(IPAMDL(174).EQ.1) THEN
5257 YEFF = 1.D0+(1.D0-Y1)**2
5258 185 CONTINUE
5259 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
5260 WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
5261 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
5262 ELSE
5263 Q2P1 = Q2LOW1
5264 ENDIF
5265 IF(IPAMDL(174).EQ.1) THEN
5266 YEFF = 1.D0+(1.D0-Y2)**2
5267 186 CONTINUE
5268 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
5269 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
5270 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
5271 ELSE
5272 Q2P2 = Q2LOW2
5273 ENDIF
5274C impact parameter
5275 GAIMP(1) = 1.D0/SQRT(Q2P1)
5276 GAIMP(2) = 1.D0/SQRT(Q2P2)
5277C form factor (squared)
5278 FF21 = 1.D0
5279 IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
5280 FF22 = 1.D0
5281 IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
5282 IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
5283C do the hadrons overlap?
5284 IF(ISWMDL(26).GT.0) THEN
5285 DO 190 K=1,2
5286 CALL PHO_SFECFE(SIF,COF)
5287 BIMP(1,K) = SIF*GAIMP(K)
5288 BIMP(2,K) = COF*GAIMP(K)
5289 190 CONTINUE
5290 BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
5291 & +(BIMP(2,1)-BIMP(2,2))**2)
5292 IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
5293 ENDIF
5294C photon data
5295 GYY(1) = Y1
5296 GQ2(1) = Q2P1
5297 GYY(2) = Y2
5298 GQ2(2) = Q2P2
5299C
5300
5301C incoming hadron 1
5302 PINI(1,1) = 0.D0
5303 PINI(2,1) = 0.D0
5304 PINI(3,1) = EE
5305 PINI(4,1) = EE
5306 PINI(5,1) = 0.D0
5307C outgoing hadron 1
5308 YQ2 = SQRT((1.D0-Y1)*Q2P1)
5309 Q2E = Q2P1/(4.D0*EE)
5310 E1Y = EE*(1.D0-Y1)
5311 CALL PHO_SFECFE(SIF,COF)
5312 PFIN(1,1) = YQ2*COF
5313 PFIN(2,1) = YQ2*SIF
5314 PFIN(3,1) = E1Y-Q2E
5315 PFIN(4,1) = E1Y+Q2E
5316 PFIN(5,1) = 0.D0
5317 PFPHI(1) = ATAN2(COF,SIF)
5318 PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
5319C photon 1
5320 P1(1) = -PFIN(1,1)
5321 P1(2) = -PFIN(2,1)
5322 P1(3) = PINI(3,1)-PFIN(3,1)
5323 P1(4) = PINI(4,1)-PFIN(4,1)
5324C incoming hadron 2
5325 PINI(1,2) = 0.D0
5326 PINI(2,2) = 0.D0
5327 PINI(3,2) = -EE
5328 PINI(4,2) = EE
5329 PINI(5,2) = 0.D0
5330C outgoing hadron 2
5331 YQ2 = SQRT((1.D0-Y2)*Q2P2)
5332 Q2E = Q2P2/(4.D0*EE)
5333 E1Y = EE*(1.D0-Y2)
5334 CALL PHO_SFECFE(SIF,COF)
5335 PFIN(1,2) = YQ2*COF
5336 PFIN(2,2) = YQ2*SIF
5337 PFIN(3,2) = -E1Y+Q2E
5338 PFIN(4,2) = E1Y+Q2E
5339 PFIN(5,2) = 0.D0
5340 PFPHI(2) = ATAN2(COF,SIF)
5341 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
5342C photon 2
5343 P2(1) = -PFIN(1,2)
5344 P2(2) = -PFIN(2,2)
5345 P2(3) = PINI(3,2)-PFIN(3,2)
5346 P2(4) = PINI(4,2)-PFIN(4,2)
5347C ECMS cut
5348 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
5349 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
5350 IF(GGECM.LT.0.1D0) GOTO 175
5351 GGECM = SQRT(GGECM)
5352 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5353C
5354 PGAM(1,1) = P1(1)
5355 PGAM(2,1) = P1(2)
5356 PGAM(3,1) = P1(3)
5357 PGAM(4,1) = P1(4)
5358 PGAM(5,1) = -SQRT(Q2P1)
5359 PGAM(1,2) = P2(1)
5360 PGAM(2,2) = P2(2)
5361 PGAM(3,2) = P2(3)
5362 PGAM(4,2) = P2(4)
5363 PGAM(5,2) = -SQRT(Q2P2)
5364C photon helicities
5365 IGHEL(1) = 1
5366 IGHEL(2) = 1
5367C cut given by user
5368 CALL PHO_PRESEL(5,IREJ)
5369 IF(IREJ.NE.0) GOTO 175
5370C event generation
5371 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5372 IF(IREJ.NE.0) GOTO 150
5373
5374C statistics
5375 AY1 = AY1+Y1
5376 AYS1 = AYS1+Y1*Y1
5377 AY2 = AY2+Y2
5378 AYS2 = AYS2+Y2*Y2
5379 Q21MIN = MIN(Q21MIN,Q2P1)
5380 Q22MIN = MIN(Q22MIN,Q2P2)
5381 Q21MAX = MAX(Q21MAX,Q2P1)
5382 Q22MAX = MAX(Q22MAX,Q2P2)
5383 YY1MIN = MIN(YY1MIN,Y1)
5384 YY2MIN = MIN(YY2MIN,Y2)
5385 YY1MAX = MAX(YY1MAX,Y1)
5386 YY2MAX = MAX(YY2MAX,Y2)
5387 Q21AVE = Q21AVE+Q2P1
5388 Q22AVE = Q22AVE+Q2P2
5389 Q21AV2 = Q21AV2+Q2P1*Q2P1
5390 Q22AV2 = Q22AV2+Q2P2*Q2P2
5391C histograms
5392 CALL PHO_PHIST(1,HSWGHT(0))
5393 CALL PHO_LHIST(1,HSWGHT(0))
5394 200 CONTINUE
5395C
5396 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
5397 WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
5398 AY1 = AY1/DBLE(NITER)
5399 AYS1 = AYS1/DBLE(NITER)
5400 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5401 AY2 = AY2/DBLE(NITER)
5402 AYS2 = AYS2/DBLE(NITER)
5403 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5404 Q21AVE = Q21AVE/DBLE(NITER)
5405 Q21AV2 = Q21AV2/DBLE(NITER)
5406 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
5407 Q22AVE = Q22AVE/DBLE(NITER)
5408 Q22AV2 = Q22AV2/DBLE(NITER)
5409 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
5410 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5411C output of statistics, histograms
5412 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5413 &'=========================================================',
5414 &' ***** simulated cross section: ',WEIGHT,' mb *****',
5415 &'========================================================='
5416 WRITE(LO,'(//1X,A,3I10)')
5417 & 'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5418 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5419 & WGY,WEIGHT
5420 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
5421 & AY1,DAY1
5422 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
5423 & AY2,DAY2
5424 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
5425 & YY1MIN,YY1MAX
5426 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
5427 & YY2MIN,YY2MAX
5428 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
5429 & Q21AVE,Q21AV2
5430 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
5431 & Q21MIN,Q21MAX
5432 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
5433 & Q22AVE,Q22AV2
5434 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
5435 & Q22MIN,Q22MAX
5436C
5437 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5438 IF(NITER.GT.1) THEN
5439 CALL PHO_PHIST(-2,WEIGHT)
5440 CALL PHO_LHIST(-2,WEIGHT)
5441 ELSE
5442 WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
5443 ENDIF
5444
5445 END
5446
5447*$ CREATE PHO_GGHIOG.FOR
5448*COPY PHO_GGHIOG
5449CDECK ID>, PHO_GGHIOG
5450 SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
5451C**********************************************************************
5452C
5453C interface to call PHOJET (variable energy run) for
5454C gamma-gamma collisions via heavy ions (geometrical approach)
5455C
5456C
5457C input: EEN LAB system energy per nucleon
5458C NA atomic number of ion/hadron
5459C NZ charge number of ion/hadron
5460C NEVENT number of events to generate
5461C from /LEPCUT/:
5462C YMIN1,2 lower limit of Y
5463C (energy fraction taken by photon from hadron)
5464C YMAX1,2 upper cutoff for Y, necessary to avoid
5465C underflows
5466C
5467C currently implemented approximation similar to:
5468C
5469C
5470C**********************************************************************
5471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5472 SAVE
5473
5474 PARAMETER ( DEPS = 1.D-20,
5475 & PI = 3.14159265359D0 )
5476
5477C input/output channels
5478 INTEGER LI,LO
5479 COMMON /POINOU/ LI,LO
5480C event debugging information
5481 INTEGER NMAXD
5482 PARAMETER (NMAXD=100)
5483 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
5484 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5485 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5486 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5487C photon flux kinematics and cuts
5488 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5489 & YMIN1,YMAX1,YMIN2,YMAX2,
5490 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5491 & THMIN1,THMAX1,THMIN2,THMAX2
5492 INTEGER ITAG1,ITAG2
5493 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5494 & YMIN1,YMAX1,YMIN2,YMAX2,
5495 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5496 & THMIN1,THMAX1,THMIN2,THMAX2,
5497 & ITAG1,ITAG2
5498C gamma-lepton or gamma-hadron vertex information
5499 INTEGER IGHEL,IDPSRC,IDBSRC
5500 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5501 & RADSRC,AMSRC,GAMSRC
5502 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5503 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5504 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5505C nucleon-nucleus / nucleus-nucleus interface to DPMJET
5506 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5507 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5508 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5509 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5510C event weights and generated cross section
5511 INTEGER IPOWGC,ISWCUT,IVWGHT
5512 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5513 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5514 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5515
5516 PARAMETER (Max_tab=100)
5517 DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
5518
5519C
5520 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
5521 & '---------------------------------------'
5522C hadron size and mass
5523 FM2GEV = 5.07D0
5524 HIMASS = DBLE(NA)*0.938D0
5525 HIMA2 = HIMASS**2
5526 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5527 ALPHA = DBLE(NZ**2)/137.D0
5528C total hadron / heavy ion energy
5529 EE = EEN*DBLE(NA)
5530 GAMMA = EE/HIMASS
5531C setup /POFSRC/
5532 GAMSRC(1) = GAMMA
5533 GAMSRC(2) = GAMMA
5534 RADSRC(1) = HIRADI
5535 RADSRC(2) = HIRADI
5536 AMSRC(1) = HIMASS
5537 AMSRC(1) = HIMASS
5538C kinematic limitations
5539 YMI = (ECMIN/(2.D0*EE))**2
5540 IF(YMIN1.LT.YMI) THEN
5541 WRITE(LO,'(/1X,A,2E12.5)')
5542 & 'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
5543 YMIN1 = YMI
5544 ELSE IF(YMIN1.GT.YMI) THEN
5545 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5546 & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5547 & ' INSTEAD OF',YMIN1
5548 ENDIF
5549 IF(YMIN2.LT.YMI) THEN
5550 WRITE(LO,'(/1X,A,2E12.5)')
5551 & 'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
5552 YMIN2 = YMI
5553 ELSE IF(YMIN2.GT.YMI) THEN
5554 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5555 & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5556 & ' INSTEAD OF',YMIN2
5557 ENDIF
5558C debug output
5559 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
5560 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
5561 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
5562 WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA ',GAMMA
5563 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
5564 & YMAX1
5565 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
5566 & YMAX2
5567 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
5568 & 2.D0*EEN,2.D0*EE
5569 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
5570C hadron numbers set to 0
5571 IDPSRC(1) = 0
5572 IDBSRC(1) = 0
5573 IDPSRC(2) = 0
5574 IDBSRC(2) = 0
5575C table of flux function, log interpolation
5576 YMIN = YMIN1
5577 YMAX = YMAX1
5578 YMAX = MIN(YMAX,0.9999999D0)
5579 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5580 TABYL(0) = LOG(YMIN)
5581 FFMAX = 0.D0
5582 DO 100 I=1,Max_tab
5583 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5584 WG = EE*Y
5585 XI = WG*HIRADI/GAMMA
5586 FF = ALPHA*PHO_GGFLCL(XI)/Y
5587 FFMAX = MAX(FF,FFMAX)
5588 IF(FF.LT.1.D-10*FFMAX) THEN
5589 WRITE(LO,'(/1X,A,2E12.4)')
5590 & 'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
5591 YMAX1 = MIN(Y,YMAX1)
5592 GOTO 101
5593 ENDIF
5594 100 CONTINUE
5595 101 CONTINUE
5596 YMIN = YMIN2
5597 YMAX = YMAX2
5598 YMAX = MIN(YMAX,0.9999999D0)
5599 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5600 TABYL(0) = LOG(YMIN)
5601 FFMAX = 0.D0
5602 DO 102 I=1,Max_tab
5603 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5604 WG = EE*Y
5605 XI = WG*HIRADI/GAMMA
5606 FF = ALPHA*PHO_GGFLCL(XI)/Y
5607 FFMAX = MAX(FF,FFMAX)
5608 IF(FF.LT.1.D-10*FFMAX) THEN
5609 WRITE(LO,'(/1X,A,2E12.4)')
5610 & 'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
5611 YMAX2 = MIN(Y,YMAX2)
5612 GOTO 103
5613 ENDIF
5614 102 CONTINUE
5615 103 CONTINUE
5616 YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5617 IF(YMI.GT.YMIN1) THEN
5618 WRITE(LO,'(/1X,A,2E12.4)')
5619 & 'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
5620 YMIN1 = YMI
5621 ENDIF
5622 YMAX1 = MIN(YMAX,YMAX1)
5623 YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5624 IF(YMI.GT.YMIN2) THEN
5625 WRITE(LO,'(/1X,A,2E12.4)')
5626 & 'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
5627 YMIN2 = YMI
5628 ENDIF
5629C
5630 YMIN = YMIN1
5631 YMAX = YMAX1
5632 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5633 TABCU(0) = 0.D0
5634 TABYL(0) = LOG(YMIN)
5635 FLUX = 0.D0
5636 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5637 & 'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
5638 DO 105 I=1,Max_tab
5639 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5640 WG = EE*Y
5641 XI = WG*HIRADI/GAMMA
5642 FF = ALPHA*PHO_GGFLCL(XI)/Y
5643 FFMAX = MAX(FF,FFMAX)
5644 TABCU(I) = TABCU(I-1)+FF*Y
5645 TABYL(I) = LOG(Y)
5646 FLUX = FLUX+Y*FF
5647 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
5648 105 CONTINUE
5649 FLUX = FLUX*DELLY
5650 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5651 & 'PHO_GGHIOG: integrated flux (one side):',FLUX
5652C
5653C initialization
5654C photon 1
5655 EGAM = YMAX*EE
5656 P1(1) = 0.D0
5657 P1(2) = 0.D0
5658 P1(3) = EGAM
5659 P1(4) = EGAM
5660C photon 2
5661 EGAM = YMAX*EE
5662 P2(1) = 0.D0
5663 P2(2) = 0.D0
5664 P2(3) = -EGAM
5665 P2(4) = EGAM
5666 CALL PHO_SETPAR(1,22,0,0.D0)
5667 CALL PHO_SETPAR(2,22,0,0.D0)
5668 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5669 CALL PHO_PHIST(-1,SIGMAX)
5670 CALL PHO_LHIST(-1,SIGMAX)
5671C
5672C generation of events
5673
5674 AY1 = 0.D0
5675 AY2 = 0.D0
5676 AYS1 = 0.D0
5677 AYS2 = 0.D0
5678 YY1MIN = 1.D30
5679 YY2MIN = 1.D30
5680 YY1MAX = 0.D0
5681 YY2MAX = 0.D0
5682 NITER = NEVENT
5683 ITRY = 0
5684 ITRW = 0
5685 DO 200 I=1,NITER
5686 150 CONTINUE
5687 ITRY = ITRY+1
5688 175 CONTINUE
5689 ITRW = ITRW+1
5690 XI = DT_RNDM(AY1)*TABCU(Max_tab)
5691 DO 110 K=1,Max_tab
5692 IF(TABCU(K).GE.XI) THEN
5693 Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5694 Y1 = EXP(Y1)
5695 GOTO 120
5696 ENDIF
5697 110 CONTINUE
5698 Y1 = YMAX1
5699 120 CONTINUE
5700 XI = DT_RNDM(AY2)*TABCU(Max_tab)
5701 DO 130 K=1,Max_tab
5702 IF(TABCU(K).GE.XI) THEN
5703 Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5704 Y2 = EXP(Y2)
5705 GOTO 140
5706 ENDIF
5707 130 CONTINUE
5708 Y2 = YMAX2
5709 140 CONTINUE
5710C setup kinematics
5711
5712 GYY(1) = Y1
5713 GQ2(1) = 0.D0
5714 GYY(2) = Y2
5715 GQ2(2) = 0.D0
5716C incoming electron 1
5717 PINI(1,1) = 0.D0
5718 PINI(2,1) = 0.D0
5719 PINI(3,1) = EE
5720 PINI(4,1) = EE
5721 PINI(5,1) = 0.D0
5722C outgoing electron 1
5723 E1Y = EE*(1.D0-Y1)
5724 PFIN(1,1) = 0.D0
5725 PFIN(2,1) = 0.D0
5726 PFIN(3,1) = E1Y
5727 PFIN(4,1) = E1Y
5728 PFIN(5,1) = 0.D0
5729C photon 1
5730 P1(1) = -PFIN(1,1)
5731 P1(2) = -PFIN(2,1)
5732 P1(3) = PINI(3,1)-PFIN(3,1)
5733 P1(4) = PINI(4,1)-PFIN(4,1)
5734C incoming electron 2
5735 PINI(1,2) = 0.D0
5736 PINI(2,2) = 0.D0
5737 PINI(3,2) = -EE
5738 PINI(4,2) = EE
5739 PINI(5,2) = 0.D0
5740C outgoing electron 2
5741 E1Y = EE*(1.D0-Y2)
5742 PFIN(1,2) = 0.D0
5743 PFIN(2,2) = 0.D0
5744 PFIN(3,2) = -E1Y
5745 PFIN(4,2) = E1Y
5746 PFIN(5,2) = 0.D0
5747C photon 2
5748 P2(1) = -PFIN(1,2)
5749 P2(2) = -PFIN(2,2)
5750 P2(3) = PINI(3,2)-PFIN(3,2)
5751 P2(4) = PINI(4,2)-PFIN(4,2)
5752C ECMS cut
5753 GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
5754 IF(GGECM.LT.0.1D0) GOTO 175
5755 GGECM = SQRT(GGECM)
5756 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5757 PGAM(1,1) = P1(1)
5758 PGAM(2,1) = P1(2)
5759 PGAM(3,1) = P1(3)
5760 PGAM(4,1) = P1(4)
5761 PGAM(5,1) = 0.D0
5762 PGAM(1,2) = P2(1)
5763 PGAM(2,2) = P2(2)
5764 PGAM(3,2) = P2(3)
5765 PGAM(4,2) = P2(4)
5766 PGAM(5,2) = 0.D0
5767C impact parameter constraints
5768 XI1 = P1(4)*HIRADI/GAMMA
5769 XI2 = P2(4)*HIRADI/GAMMA
5770 FLX = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
5771 FCORR = PHO_GGFLCR(HIRADI)
5772 WGX = (FLX-FCORR)/FLX
5773 IF(DT_RNDM(Y2).GT.WGX) GOTO 175
5774C photon helicities
5775 IGHEL(1) = 1
5776 IGHEL(2) = 1
5777C cut given by user
5778 CALL PHO_PRESEL(5,IREJ)
5779 IF(IREJ.NE.0) GOTO 175
5780C event generation
5781 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5782 IF(IREJ.NE.0) GOTO 150
5783
5784C statistics
5785 AY1 = AY1+Y1
5786 AYS1 = AYS1+Y1*Y1
5787 AY2 = AY2+Y2
5788 AYS2 = AYS2+Y2*Y2
5789 YY1MIN = MIN(YY1MIN,Y1)
5790 YY2MIN = MIN(YY2MIN,Y2)
5791 YY1MAX = MAX(YY1MAX,Y1)
5792 YY2MAX = MAX(YY2MAX,Y2)
5793C histograms
5794 CALL PHO_PHIST(1,HSWGHT(0))
5795 CALL PHO_LHIST(1,HSWGHT(0))
5796 200 CONTINUE
5797C
5798 WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
5799 AY1 = AY1/DBLE(NITER)
5800 AYS1 = AYS1/DBLE(NITER)
5801 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5802 AY2 = AY2/DBLE(NITER)
5803 AYS2 = AYS2/DBLE(NITER)
5804 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5805 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5806C output of statistics, histograms
5807 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5808 &'=========================================================',
5809 &' ***** simulated cross section: ',WEIGHT,' mb *****',
5810 &'========================================================='
5811 WRITE(LO,'(//1X,A,3I12)')
5812 & 'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5813 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5814 & WGY,WEIGHT
5815 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
5816 & AY1,DAY1
5817 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
5818 & AY2,DAY2
5819 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
5820 & YY1MIN,YY1MAX
5821 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
5822 & YY2MIN,YY2MAX
5823
5824C
5825 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5826 IF(NITER.GT.1) THEN
5827 CALL PHO_PHIST(-2,WEIGHT)
5828 CALL PHO_LHIST(-2,WEIGHT)
5829 ELSE
5830 WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
5831 ENDIF
5832
5833 END
5834
5835*$ CREATE PHO_GGFLCL.FOR
5836*COPY PHO_GGFLCL
5837CDECK ID>, PHO_GGFLCL
5838 DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
5839C*********************************************************************
5840C
5841C semi-classical photon flux (geometrical model)
5842C
5843C*********************************************************************
5844 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5845 SAVE
5846
5847 PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
5848 & -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
5849
5850 END
5851
5852*$ CREATE PHO_GGFLCR.FOR
5853*COPY PHO_GGFLCR
5854CDECK ID>, PHO_GGFLCR
5855 DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
5856C*********************************************************************
5857C
5858C semi-classical photon flux correction due to
5859C overlap in impact parameter space (geometrical model)
5860C
5861C*********************************************************************
5862 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5863 SAVE
5864
5865 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
5866
5867C input/output channels
5868 INTEGER LI,LO
5869 COMMON /POINOU/ LI,LO
5870C gamma-lepton or gamma-hadron vertex information
5871 INTEGER IGHEL,IDPSRC,IDBSRC
5872 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5873 & RADSRC,AMSRC,GAMSRC
5874 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5875 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5876 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5877
5878 DIMENSION XGAUSS(126),WGAUSS(126)
5879
5880 DATA XGAUSS(1)/ .57735026918962576D0/
5881 DATA XGAUSS(2)/-.57735026918962576D0/
5882 DATA WGAUSS(1)/ 1.00000000000000000D0/
5883 DATA WGAUSS(2)/ 1.00000000000000000D0/
5884
5885 DATA XGAUSS(3)/ .33998104358485627D0/
5886 DATA XGAUSS(4)/ .86113631159405258D0/
5887 DATA XGAUSS(5)/-.33998104358485627D0/
5888 DATA XGAUSS(6)/-.86113631159405258D0/
5889 DATA WGAUSS(3)/ .65214515486254613D0/
5890 DATA WGAUSS(4)/ .34785484513745385D0/
5891 DATA WGAUSS(5)/ .65214515486254613D0/
5892 DATA WGAUSS(6)/ .34785484513745385D0/
5893
5894 DATA XGAUSS(7)/ .18343464249564981D0/
5895 DATA XGAUSS(8)/ .52553240991632899D0/
5896 DATA XGAUSS(9)/ .79666647741362674D0/
5897 DATA XGAUSS(10)/ .96028985649753623D0/
5898 DATA XGAUSS(11)/-.18343464249564981D0/
5899 DATA XGAUSS(12)/-.52553240991632899D0/
5900 DATA XGAUSS(13)/-.79666647741362674D0/
5901 DATA XGAUSS(14)/-.96028985649753623D0/
5902 DATA WGAUSS(7)/ .36268378337836198D0/
5903 DATA WGAUSS(8)/ .31370664587788727D0/
5904 DATA WGAUSS(9)/ .22238103445337448D0/
5905 DATA WGAUSS(10)/ .10122853629037627D0/
5906 DATA WGAUSS(11)/ .36268378337836198D0/
5907 DATA WGAUSS(12)/ .31370664587788727D0/
5908 DATA WGAUSS(13)/ .22238103445337448D0/
5909 DATA WGAUSS(14)/ .10122853629037627D0/
5910
5911 DATA XGAUSS(15)/ .0950125098376374402D0/
5912 DATA XGAUSS(16)/ .281603550779258913D0/
5913 DATA XGAUSS(17)/ .458016777657227386D0/
5914 DATA XGAUSS(18)/ .617876244402643748D0/
5915 DATA XGAUSS(19)/ .755404408355003034D0/
5916 DATA XGAUSS(20)/ .865631202387831744D0/
5917 DATA XGAUSS(21)/ .944575023073232576D0/
5918 DATA XGAUSS(22)/ .989400934991649933D0/
5919 DATA XGAUSS(23)/-.0950125098376374402D0/
5920 DATA XGAUSS(24)/-.281603550779258913D0/
5921 DATA XGAUSS(25)/-.458016777657227386D0/
5922 DATA XGAUSS(26)/-.617876244402643748D0/
5923 DATA XGAUSS(27)/-.755404408355003034D0/
5924 DATA XGAUSS(28)/-.865631202387831744D0/
5925 DATA XGAUSS(29)/-.944575023073232576D0/
5926 DATA XGAUSS(30)/-.989400934991649933D0/
5927 DATA WGAUSS(15)/ .189450610455068496D0/
5928 DATA WGAUSS(16)/ .182603415044923589D0/
5929 DATA WGAUSS(17)/ .169156519395002538D0/
5930 DATA WGAUSS(18)/ .149595988816576732D0/
5931 DATA WGAUSS(19)/ .124628971255533872D0/
5932 DATA WGAUSS(20)/ .0951585116824927848D0/
5933 DATA WGAUSS(21)/ .0622535239386478929D0/
5934 DATA WGAUSS(22)/ .0271524594117540949D0/
5935 DATA WGAUSS(23)/ .189450610455068496D0/
5936 DATA WGAUSS(24)/ .182603415044923589D0/
5937 DATA WGAUSS(25)/ .169156519395002538D0/
5938 DATA WGAUSS(26)/ .149595988816576732D0/
5939 DATA WGAUSS(27)/ .124628971255533872D0/
5940 DATA WGAUSS(28)/ .0951585116824927848D0/
5941 DATA WGAUSS(29)/ .0622535239386478929D0/
5942 DATA WGAUSS(30)/ .0271524594117540949D0/
5943
5944 DATA XGAUSS(31)/ .0483076656877383162D0/
5945 DATA XGAUSS(32)/ .144471961582796493D0/
5946 DATA XGAUSS(33)/ .239287362252137075D0/
5947 DATA XGAUSS(34)/ .331868602282127650D0/
5948 DATA XGAUSS(35)/ .421351276130635345D0/
5949 DATA XGAUSS(36)/ .506899908932229390D0/
5950 DATA XGAUSS(37)/ .587715757240762329D0/
5951 DATA XGAUSS(38)/ .663044266930215201D0/
5952 DATA XGAUSS(39)/ .732182118740289680D0/
5953 DATA XGAUSS(40)/ .794483795967942407D0/
5954 DATA XGAUSS(41)/ .849367613732569970D0/
5955 DATA XGAUSS(42)/ .896321155766052124D0/
5956 DATA XGAUSS(43)/ .934906075937739689D0/
5957 DATA XGAUSS(44)/ .964762255587506430D0/
5958 DATA XGAUSS(45)/ .985611511545268335D0/
5959 DATA XGAUSS(46)/ .997263861849481564D0/
5960 DATA XGAUSS(47)/-.0483076656877383162D0/
5961 DATA XGAUSS(48)/-.144471961582796493D0/
5962 DATA XGAUSS(49)/-.239287362252137075D0/
5963 DATA XGAUSS(50)/-.331868602282127650D0/
5964 DATA XGAUSS(51)/-.421351276130635345D0/
5965 DATA XGAUSS(52)/-.506899908932229390D0/
5966 DATA XGAUSS(53)/-.587715757240762329D0/
5967 DATA XGAUSS(54)/-.663044266930215201D0/
5968 DATA XGAUSS(55)/-.732182118740289680D0/
5969 DATA XGAUSS(56)/-.794483795967942407D0/
5970 DATA XGAUSS(57)/-.849367613732569970D0/
5971 DATA XGAUSS(58)/-.896321155766052124D0/
5972 DATA XGAUSS(59)/-.934906075937739689D0/
5973 DATA XGAUSS(60)/-.964762255587506430D0/
5974 DATA XGAUSS(61)/-.985611511545268335D0/
5975 DATA XGAUSS(62)/-.997263861849481564D0/
5976 DATA WGAUSS(31)/ .0965400885147278006D0/
5977 DATA WGAUSS(32)/ .0956387200792748594D0/
5978 DATA WGAUSS(33)/ .0938443990808045654D0/
5979 DATA WGAUSS(34)/ .0911738786957638847D0/
5980 DATA WGAUSS(35)/ .0876520930044038111D0/
5981 DATA WGAUSS(36)/ .0833119242269467552D0/
5982 DATA WGAUSS(37)/ .0781938957870703065D0/
5983 DATA WGAUSS(38)/ .0723457941088485062D0/
5984 DATA WGAUSS(39)/ .0658222227763618468D0/
5985 DATA WGAUSS(40)/ .0586840934785355471D0/
5986 DATA WGAUSS(41)/ .0509980592623761762D0/
5987 DATA WGAUSS(42)/ .0428358980222266807D0/
5988 DATA WGAUSS(43)/ .0342738629130214331D0/
5989 DATA WGAUSS(44)/ .0253920653092620595D0/
5990 DATA WGAUSS(45)/ .0162743947309056706D0/
5991 DATA WGAUSS(46)/ .00701861000947009660D0/
5992 DATA WGAUSS(47)/ .0965400885147278006D0/
5993 DATA WGAUSS(48)/ .0956387200792748594D0/
5994 DATA WGAUSS(49)/ .0938443990808045654D0/
5995 DATA WGAUSS(50)/ .0911738786957638847D0/
5996 DATA WGAUSS(51)/ .0876520930044038111D0/
5997 DATA WGAUSS(52)/ .0833119242269467552D0/
5998 DATA WGAUSS(53)/ .0781938957870703065D0/
5999 DATA WGAUSS(54)/ .0723457941088485062D0/
6000 DATA WGAUSS(55)/ .0658222227763618468D0/
6001 DATA WGAUSS(56)/ .0586840934785355471D0/
6002 DATA WGAUSS(57)/ .0509980592623761762D0/
6003 DATA WGAUSS(58)/ .0428358980222266807D0/
6004 DATA WGAUSS(59)/ .0342738629130214331D0/
6005 DATA WGAUSS(60)/ .0253920653092620595D0/
6006 DATA WGAUSS(61)/ .0162743947309056706D0/
6007 DATA WGAUSS(62)/ .00701861000947009660D0/
6008
6009 DATA XGAUSS(63)/ .02435029266342443250D0/
6010 DATA XGAUSS(64)/ .0729931217877990394D0/
6011 DATA XGAUSS(65)/ .121462819296120554D0/
6012 DATA XGAUSS(66)/ .169644420423992818D0/
6013 DATA XGAUSS(67)/ .217423643740007084D0/
6014 DATA XGAUSS(68)/ .264687162208767416D0/
6015 DATA XGAUSS(69)/ .311322871990210956D0/
6016 DATA XGAUSS(70)/ .357220158337668116D0/
6017 DATA XGAUSS(71)/ .402270157963991604D0/
6018 DATA XGAUSS(72)/ .446366017253464088D0/
6019 DATA XGAUSS(73)/ .489403145707052957D0/
6020 DATA XGAUSS(74)/ .531279464019894546D0/
6021 DATA XGAUSS(75)/ .571895646202634034D0/
6022 DATA XGAUSS(76)/ .611155355172393250D0/
6023 DATA XGAUSS(77)/ .648965471254657340D0/
6024 DATA XGAUSS(78)/ .685236313054233243D0/
6025 DATA XGAUSS(79)/ .719881850171610827D0/
6026 DATA XGAUSS(80)/ .752819907260531897D0/
6027 DATA XGAUSS(81)/ .783972358943341408D0/
6028 DATA XGAUSS(82)/ .813265315122797560D0/
6029 DATA XGAUSS(83)/ .840629296252580363D0/
6030 DATA XGAUSS(84)/ .865999398154092820D0/
6031 DATA XGAUSS(85)/ .889315445995114106D0/
6032 DATA XGAUSS(86)/ .910522137078502806D0/
6033 DATA XGAUSS(87)/ .929569172131939576D0/
6034 DATA XGAUSS(88)/ .946411374858402816D0/
6035 DATA XGAUSS(89)/ .961008799652053719D0/
6036 DATA XGAUSS(90)/ .973326827789910964D0/
6037 DATA XGAUSS(91)/ .983336253884625957D0/
6038 DATA XGAUSS(92)/ .991013371476744321D0/
6039 DATA XGAUSS(93)/ .996340116771955279D0/
6040 DATA XGAUSS(94)/ .999305041735772139D0/
6041 DATA XGAUSS(95)/-.02435029266342443250D0/
6042 DATA XGAUSS(96)/-.0729931217877990394D0/
6043 DATA XGAUSS(97)/-.121462819296120554D0/
6044 DATA XGAUSS(98)/-.169644420423992818D0/
6045 DATA XGAUSS(99)/-.217423643740007084D0/
6046 DATA XGAUSS(100)/-.264687162208767416D0/
6047 DATA XGAUSS(101)/-.311322871990210956D0/
6048 DATA XGAUSS(102)/-.357220158337668116D0/
6049 DATA XGAUSS(103)/-.402270157963991604D0/
6050 DATA XGAUSS(104)/-.446366017253464088D0/
6051 DATA XGAUSS(105)/-.489403145707052957D0/
6052 DATA XGAUSS(106)/-.531279464019894546D0/
6053 DATA XGAUSS(107)/-.571895646202634034D0/
6054 DATA XGAUSS(108)/-.611155355172393250D0/
6055 DATA XGAUSS(109)/-.648965471254657340D0/
6056 DATA XGAUSS(110)/-.685236313054233243D0/
6057 DATA XGAUSS(111)/-.719881850171610827D0/
6058 DATA XGAUSS(112)/-.752819907260531897D0/
6059 DATA XGAUSS(113)/-.783972358943341408D0/
6060 DATA XGAUSS(114)/-.813265315122797560D0/
6061 DATA XGAUSS(115)/-.840629296252580363D0/
6062 DATA XGAUSS(116)/-.865999398154092820D0/
6063 DATA XGAUSS(117)/-.889315445995114106D0/
6064 DATA XGAUSS(118)/-.910522137078502806D0/
6065 DATA XGAUSS(119)/-.929569172131939576D0/
6066 DATA XGAUSS(120)/-.946411374858402816D0/
6067 DATA XGAUSS(121)/-.961008799652053719D0/
6068 DATA XGAUSS(122)/-.973326827789910964D0/
6069 DATA XGAUSS(123)/-.983336253884625957D0/
6070 DATA XGAUSS(124)/-.991013371476744321D0/
6071 DATA XGAUSS(125)/-.996340116771955279D0/
6072 DATA XGAUSS(126)/-.999305041735772139D0/
6073 DATA WGAUSS(63)/ .0486909570091397204D0/
6074 DATA WGAUSS(64)/ .0485754674415034269D0/
6075 DATA WGAUSS(65)/ .0483447622348029572D0/
6076 DATA WGAUSS(66)/ .0479993885964583077D0/
6077 DATA WGAUSS(67)/ .0475401657148303087D0/
6078 DATA WGAUSS(68)/ .0469681828162100173D0/
6079 DATA WGAUSS(69)/ .0462847965813144172D0/
6080 DATA WGAUSS(70)/ .0454916279274181445D0/
6081 DATA WGAUSS(71)/ .0445905581637565631D0/
6082 DATA WGAUSS(72)/ .0435837245293234534D0/
6083 DATA WGAUSS(73)/ .0424735151236535890D0/
6084 DATA WGAUSS(74)/ .0412625632426235286D0/
6085 DATA WGAUSS(75)/ .0399537411327203414D0/
6086 DATA WGAUSS(76)/ .0385501531786156291D0/
6087 DATA WGAUSS(77)/ .0370551285402400460D0/
6088 DATA WGAUSS(78)/ .0354722132568823838D0/
6089 DATA WGAUSS(79)/ .0338051618371416094D0/
6090 DATA WGAUSS(80)/ .0320579283548515535D0/
6091 DATA WGAUSS(81)/ .0302346570724024789D0/
6092 DATA WGAUSS(82)/ .0283396726142594832D0/
6093 DATA WGAUSS(83)/ .0263774697150546587D0/
6094 DATA WGAUSS(84)/ .0243527025687108733D0/
6095 DATA WGAUSS(85)/ .0222701738083832542D0/
6096 DATA WGAUSS(86)/ .0201348231535302094D0/
6097 DATA WGAUSS(87)/ .0179517157756973431D0/
6098 DATA WGAUSS(88)/ .0157260304760247193D0/
6099 DATA WGAUSS(89)/ .0134630478967186426D0/
6100 DATA WGAUSS(90)/ .0111681394601311288D0/
6101 DATA WGAUSS(91)/ .00884675982636394772D0/
6102 DATA WGAUSS(92)/ .00650445796897836286D0/
6103 DATA WGAUSS(93)/ .00414703326056246764D0/
6104 DATA WGAUSS(94)/ .00178328072169643295D0/
6105 DATA WGAUSS(95)/ .0486909570091397204D0/
6106 DATA WGAUSS(96)/ .0485754674415034269D0/
6107 DATA WGAUSS(97)/ .0483447622348029572D0/
6108 DATA WGAUSS(98)/ .0479993885964583077D0/
6109 DATA WGAUSS(99)/ .0475401657148303087D0/
6110 DATA WGAUSS(100)/ .0469681828162100173D0/
6111 DATA WGAUSS(101)/ .0462847965813144172D0/
6112 DATA WGAUSS(102)/ .0454916279274181445D0/
6113 DATA WGAUSS(103)/ .0445905581637565631D0/
6114 DATA WGAUSS(104)/ .0435837245293234534D0/
6115 DATA WGAUSS(105)/ .0424735151236535890D0/
6116 DATA WGAUSS(106)/ .0412625632426235286D0/
6117 DATA WGAUSS(107)/ .0399537411327203414D0/
6118 DATA WGAUSS(108)/ .0385501531786156291D0/
6119 DATA WGAUSS(109)/ .0370551285402400460D0/
6120 DATA WGAUSS(110)/ .0354722132568823838D0/
6121 DATA WGAUSS(111)/ .0338051618371416094D0/
6122 DATA WGAUSS(112)/ .0320579283548515535D0/
6123 DATA WGAUSS(113)/ .0302346570724024789D0/
6124 DATA WGAUSS(114)/ .0283396726142594832D0/
6125 DATA WGAUSS(115)/ .0263774697150546587D0/
6126 DATA WGAUSS(116)/ .0243527025687108733D0/
6127 DATA WGAUSS(117)/ .0222701738083832542D0/
6128 DATA WGAUSS(118)/ .0201348231535302094D0/
6129 DATA WGAUSS(119)/ .0179517157756973431D0/
6130 DATA WGAUSS(120)/ .0157260304760247193D0/
6131 DATA WGAUSS(121)/ .0134630478967186426D0/
6132 DATA WGAUSS(122)/ .0111681394601311288D0/
6133 DATA WGAUSS(123)/ .00884675982636394772D0/
6134 DATA WGAUSS(124)/ .00650445796897836286D0/
6135 DATA WGAUSS(125)/ .00414703326056246764D0/
6136 DATA WGAUSS(126)/ .00178328072169643295D0/
6137
6138C integrate first over b1
6139C
6140C Loop incrementing the boundary
6141C
6142 tmin = 0.D0
6143 tmax = 0.25D0
6144 Sum = 0.D0
6145
6146 50 CONTINUE
6147
6148C
6149C Loop for the Gauss integration
6150C
6151 XINT=0.D0
6152 DO 100 N=1,6
6153 XINT2 = XINT
6154 XINT=0.D0
6155 DO 200 I=2**N-1,2**(N+1)-2
6156 t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
6157 b1 = RADSRC(1) * EXP (t)
6158 XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
6159 200 CONTINUE
6160 XINT = (tmax-tmin)/2.D0*XINT
6161 IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
6162 100 CONTINUE
6163 WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
6164 300 CONTINUE
6165
6166 Sum = Sum + XINT
6167 IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
6168 tmin = tmax
6169 tmax = tmax + 0.5D0
6170 GOTO 50
6171 ENDIF
6172
6173 PHO_GGFLCR = 4.D0*Pi * Sum
6174
6175 END
6176
6177*$ CREATE PHO_GGFAUX.FOR
6178*COPY PHO_GGFAUX
6179CDECK ID>, PHO_GGFAUX
6180 DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
6181C*********************************************************************
6182C
6183C auxiliary function for integration over b2,
6184C semi-classical photon flux correction due to
6185C overlap in impact parameter space (geometrical model)
6186C
6187C*********************************************************************
6188 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6189 SAVE
6190
6191 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
6192
6193C input/output channels
6194 INTEGER LI,LO
6195 COMMON /POINOU/ LI,LO
6196C gamma-lepton or gamma-hadron vertex information
6197 INTEGER IGHEL,IDPSRC,IDBSRC
6198 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6199 & RADSRC,AMSRC,GAMSRC
6200 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6201 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6202 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6203
6204 DIMENSION XGAUSS(126),WGAUSS(126)
6205
6206 DATA XGAUSS(1)/ .57735026918962576D0/
6207 DATA XGAUSS(2)/-.57735026918962576D0/
6208 DATA WGAUSS(1)/ 1.00000000000000000D0/
6209 DATA WGAUSS(2)/ 1.00000000000000000D0/
6210
6211 DATA XGAUSS(3)/ .33998104358485627D0/
6212 DATA XGAUSS(4)/ .86113631159405258D0/
6213 DATA XGAUSS(5)/-.33998104358485627D0/
6214 DATA XGAUSS(6)/-.86113631159405258D0/
6215 DATA WGAUSS(3)/ .65214515486254613D0/
6216 DATA WGAUSS(4)/ .34785484513745385D0/
6217 DATA WGAUSS(5)/ .65214515486254613D0/
6218 DATA WGAUSS(6)/ .34785484513745385D0/
6219
6220 DATA XGAUSS(7)/ .18343464249564981D0/
6221 DATA XGAUSS(8)/ .52553240991632899D0/
6222 DATA XGAUSS(9)/ .79666647741362674D0/
6223 DATA XGAUSS(10)/ .96028985649753623D0/
6224 DATA XGAUSS(11)/-.18343464249564981D0/
6225 DATA XGAUSS(12)/-.52553240991632899D0/
6226 DATA XGAUSS(13)/-.79666647741362674D0/
6227 DATA XGAUSS(14)/-.96028985649753623D0/
6228 DATA WGAUSS(7)/ .36268378337836198D0/
6229 DATA WGAUSS(8)/ .31370664587788727D0/
6230 DATA WGAUSS(9)/ .22238103445337448D0/
6231 DATA WGAUSS(10)/ .10122853629037627D0/
6232 DATA WGAUSS(11)/ .36268378337836198D0/
6233 DATA WGAUSS(12)/ .31370664587788727D0/
6234 DATA WGAUSS(13)/ .22238103445337448D0/
6235 DATA WGAUSS(14)/ .10122853629037627D0/
6236
6237 DATA XGAUSS(15)/ .0950125098376374402D0/
6238 DATA XGAUSS(16)/ .281603550779258913D0/
6239 DATA XGAUSS(17)/ .458016777657227386D0/
6240 DATA XGAUSS(18)/ .617876244402643748D0/
6241 DATA XGAUSS(19)/ .755404408355003034D0/
6242 DATA XGAUSS(20)/ .865631202387831744D0/
6243 DATA XGAUSS(21)/ .944575023073232576D0/
6244 DATA XGAUSS(22)/ .989400934991649933D0/
6245 DATA XGAUSS(23)/-.0950125098376374402D0/
6246 DATA XGAUSS(24)/-.281603550779258913D0/
6247 DATA XGAUSS(25)/-.458016777657227386D0/
6248 DATA XGAUSS(26)/-.617876244402643748D0/
6249 DATA XGAUSS(27)/-.755404408355003034D0/
6250 DATA XGAUSS(28)/-.865631202387831744D0/
6251 DATA XGAUSS(29)/-.944575023073232576D0/
6252 DATA XGAUSS(30)/-.989400934991649933D0/
6253 DATA WGAUSS(15)/ .189450610455068496D0/
6254 DATA WGAUSS(16)/ .182603415044923589D0/
6255 DATA WGAUSS(17)/ .169156519395002538D0/
6256 DATA WGAUSS(18)/ .149595988816576732D0/
6257 DATA WGAUSS(19)/ .124628971255533872D0/
6258 DATA WGAUSS(20)/ .0951585116824927848D0/
6259 DATA WGAUSS(21)/ .0622535239386478929D0/
6260 DATA WGAUSS(22)/ .0271524594117540949D0/
6261 DATA WGAUSS(23)/ .189450610455068496D0/
6262 DATA WGAUSS(24)/ .182603415044923589D0/
6263 DATA WGAUSS(25)/ .169156519395002538D0/
6264 DATA WGAUSS(26)/ .149595988816576732D0/
6265 DATA WGAUSS(27)/ .124628971255533872D0/
6266 DATA WGAUSS(28)/ .0951585116824927848D0/
6267 DATA WGAUSS(29)/ .0622535239386478929D0/
6268 DATA WGAUSS(30)/ .0271524594117540949D0/
6269
6270 DATA XGAUSS(31)/ .0483076656877383162D0/
6271 DATA XGAUSS(32)/ .144471961582796493D0/
6272 DATA XGAUSS(33)/ .239287362252137075D0/
6273 DATA XGAUSS(34)/ .331868602282127650D0/
6274 DATA XGAUSS(35)/ .421351276130635345D0/
6275 DATA XGAUSS(36)/ .506899908932229390D0/
6276 DATA XGAUSS(37)/ .587715757240762329D0/
6277 DATA XGAUSS(38)/ .663044266930215201D0/
6278 DATA XGAUSS(39)/ .732182118740289680D0/
6279 DATA XGAUSS(40)/ .794483795967942407D0/
6280 DATA XGAUSS(41)/ .849367613732569970D0/
6281 DATA XGAUSS(42)/ .896321155766052124D0/
6282 DATA XGAUSS(43)/ .934906075937739689D0/
6283 DATA XGAUSS(44)/ .964762255587506430D0/
6284 DATA XGAUSS(45)/ .985611511545268335D0/
6285 DATA XGAUSS(46)/ .997263861849481564D0/
6286 DATA XGAUSS(47)/-.0483076656877383162D0/
6287 DATA XGAUSS(48)/-.144471961582796493D0/
6288 DATA XGAUSS(49)/-.239287362252137075D0/
6289 DATA XGAUSS(50)/-.331868602282127650D0/
6290 DATA XGAUSS(51)/-.421351276130635345D0/
6291 DATA XGAUSS(52)/-.506899908932229390D0/
6292 DATA XGAUSS(53)/-.587715757240762329D0/
6293 DATA XGAUSS(54)/-.663044266930215201D0/
6294 DATA XGAUSS(55)/-.732182118740289680D0/
6295 DATA XGAUSS(56)/-.794483795967942407D0/
6296 DATA XGAUSS(57)/-.849367613732569970D0/
6297 DATA XGAUSS(58)/-.896321155766052124D0/
6298 DATA XGAUSS(59)/-.934906075937739689D0/
6299 DATA XGAUSS(60)/-.964762255587506430D0/
6300 DATA XGAUSS(61)/-.985611511545268335D0/
6301 DATA XGAUSS(62)/-.997263861849481564D0/
6302 DATA WGAUSS(31)/ .0965400885147278006D0/
6303 DATA WGAUSS(32)/ .0956387200792748594D0/
6304 DATA WGAUSS(33)/ .0938443990808045654D0/
6305 DATA WGAUSS(34)/ .0911738786957638847D0/
6306 DATA WGAUSS(35)/ .0876520930044038111D0/
6307 DATA WGAUSS(36)/ .0833119242269467552D0/
6308 DATA WGAUSS(37)/ .0781938957870703065D0/
6309 DATA WGAUSS(38)/ .0723457941088485062D0/
6310 DATA WGAUSS(39)/ .0658222227763618468D0/
6311 DATA WGAUSS(40)/ .0586840934785355471D0/
6312 DATA WGAUSS(41)/ .0509980592623761762D0/
6313 DATA WGAUSS(42)/ .0428358980222266807D0/
6314 DATA WGAUSS(43)/ .0342738629130214331D0/
6315 DATA WGAUSS(44)/ .0253920653092620595D0/
6316 DATA WGAUSS(45)/ .0162743947309056706D0/
6317 DATA WGAUSS(46)/ .00701861000947009660D0/
6318 DATA WGAUSS(47)/ .0965400885147278006D0/
6319 DATA WGAUSS(48)/ .0956387200792748594D0/
6320 DATA WGAUSS(49)/ .0938443990808045654D0/
6321 DATA WGAUSS(50)/ .0911738786957638847D0/
6322 DATA WGAUSS(51)/ .0876520930044038111D0/
6323 DATA WGAUSS(52)/ .0833119242269467552D0/
6324 DATA WGAUSS(53)/ .0781938957870703065D0/
6325 DATA WGAUSS(54)/ .0723457941088485062D0/
6326 DATA WGAUSS(55)/ .0658222227763618468D0/
6327 DATA WGAUSS(56)/ .0586840934785355471D0/
6328 DATA WGAUSS(57)/ .0509980592623761762D0/
6329 DATA WGAUSS(58)/ .0428358980222266807D0/
6330 DATA WGAUSS(59)/ .0342738629130214331D0/
6331 DATA WGAUSS(60)/ .0253920653092620595D0/
6332 DATA WGAUSS(61)/ .0162743947309056706D0/
6333 DATA WGAUSS(62)/ .00701861000947009660D0/
6334
6335 DATA XGAUSS(63)/ .02435029266342443250D0/
6336 DATA XGAUSS(64)/ .0729931217877990394D0/
6337 DATA XGAUSS(65)/ .121462819296120554D0/
6338 DATA XGAUSS(66)/ .169644420423992818D0/
6339 DATA XGAUSS(67)/ .217423643740007084D0/
6340 DATA XGAUSS(68)/ .264687162208767416D0/
6341 DATA XGAUSS(69)/ .311322871990210956D0/
6342 DATA XGAUSS(70)/ .357220158337668116D0/
6343 DATA XGAUSS(71)/ .402270157963991604D0/
6344 DATA XGAUSS(72)/ .446366017253464088D0/
6345 DATA XGAUSS(73)/ .489403145707052957D0/
6346 DATA XGAUSS(74)/ .531279464019894546D0/
6347 DATA XGAUSS(75)/ .571895646202634034D0/
6348 DATA XGAUSS(76)/ .611155355172393250D0/
6349 DATA XGAUSS(77)/ .648965471254657340D0/
6350 DATA XGAUSS(78)/ .685236313054233243D0/
6351 DATA XGAUSS(79)/ .719881850171610827D0/
6352 DATA XGAUSS(80)/ .752819907260531897D0/
6353 DATA XGAUSS(81)/ .783972358943341408D0/
6354 DATA XGAUSS(82)/ .813265315122797560D0/
6355 DATA XGAUSS(83)/ .840629296252580363D0/
6356 DATA XGAUSS(84)/ .865999398154092820D0/
6357 DATA XGAUSS(85)/ .889315445995114106D0/
6358 DATA XGAUSS(86)/ .910522137078502806D0/
6359 DATA XGAUSS(87)/ .929569172131939576D0/
6360 DATA XGAUSS(88)/ .946411374858402816D0/
6361 DATA XGAUSS(89)/ .961008799652053719D0/
6362 DATA XGAUSS(90)/ .973326827789910964D0/
6363 DATA XGAUSS(91)/ .983336253884625957D0/
6364 DATA XGAUSS(92)/ .991013371476744321D0/
6365 DATA XGAUSS(93)/ .996340116771955279D0/
6366 DATA XGAUSS(94)/ .999305041735772139D0/
6367 DATA XGAUSS(95)/-.02435029266342443250D0/
6368 DATA XGAUSS(96)/-.0729931217877990394D0/
6369 DATA XGAUSS(97)/-.121462819296120554D0/
6370 DATA XGAUSS(98)/-.169644420423992818D0/
6371 DATA XGAUSS(99)/-.217423643740007084D0/
6372 DATA XGAUSS(100)/-.264687162208767416D0/
6373 DATA XGAUSS(101)/-.311322871990210956D0/
6374 DATA XGAUSS(102)/-.357220158337668116D0/
6375 DATA XGAUSS(103)/-.402270157963991604D0/
6376 DATA XGAUSS(104)/-.446366017253464088D0/
6377 DATA XGAUSS(105)/-.489403145707052957D0/
6378 DATA XGAUSS(106)/-.531279464019894546D0/
6379 DATA XGAUSS(107)/-.571895646202634034D0/
6380 DATA XGAUSS(108)/-.611155355172393250D0/
6381 DATA XGAUSS(109)/-.648965471254657340D0/
6382 DATA XGAUSS(110)/-.685236313054233243D0/
6383 DATA XGAUSS(111)/-.719881850171610827D0/
6384 DATA XGAUSS(112)/-.752819907260531897D0/
6385 DATA XGAUSS(113)/-.783972358943341408D0/
6386 DATA XGAUSS(114)/-.813265315122797560D0/
6387 DATA XGAUSS(115)/-.840629296252580363D0/
6388 DATA XGAUSS(116)/-.865999398154092820D0/
6389 DATA XGAUSS(117)/-.889315445995114106D0/
6390 DATA XGAUSS(118)/-.910522137078502806D0/
6391 DATA XGAUSS(119)/-.929569172131939576D0/
6392 DATA XGAUSS(120)/-.946411374858402816D0/
6393 DATA XGAUSS(121)/-.961008799652053719D0/
6394 DATA XGAUSS(122)/-.973326827789910964D0/
6395 DATA XGAUSS(123)/-.983336253884625957D0/
6396 DATA XGAUSS(124)/-.991013371476744321D0/
6397 DATA XGAUSS(125)/-.996340116771955279D0/
6398 DATA XGAUSS(126)/-.999305041735772139D0/
6399 DATA WGAUSS(63)/ .0486909570091397204D0/
6400 DATA WGAUSS(64)/ .0485754674415034269D0/
6401 DATA WGAUSS(65)/ .0483447622348029572D0/
6402 DATA WGAUSS(66)/ .0479993885964583077D0/
6403 DATA WGAUSS(67)/ .0475401657148303087D0/
6404 DATA WGAUSS(68)/ .0469681828162100173D0/
6405 DATA WGAUSS(69)/ .0462847965813144172D0/
6406 DATA WGAUSS(70)/ .0454916279274181445D0/
6407 DATA WGAUSS(71)/ .0445905581637565631D0/
6408 DATA WGAUSS(72)/ .0435837245293234534D0/
6409 DATA WGAUSS(73)/ .0424735151236535890D0/
6410 DATA WGAUSS(74)/ .0412625632426235286D0/
6411 DATA WGAUSS(75)/ .0399537411327203414D0/
6412 DATA WGAUSS(76)/ .0385501531786156291D0/
6413 DATA WGAUSS(77)/ .0370551285402400460D0/
6414 DATA WGAUSS(78)/ .0354722132568823838D0/
6415 DATA WGAUSS(79)/ .0338051618371416094D0/
6416 DATA WGAUSS(80)/ .0320579283548515535D0/
6417 DATA WGAUSS(81)/ .0302346570724024789D0/
6418 DATA WGAUSS(82)/ .0283396726142594832D0/
6419 DATA WGAUSS(83)/ .0263774697150546587D0/
6420 DATA WGAUSS(84)/ .0243527025687108733D0/
6421 DATA WGAUSS(85)/ .0222701738083832542D0/
6422 DATA WGAUSS(86)/ .0201348231535302094D0/
6423 DATA WGAUSS(87)/ .0179517157756973431D0/
6424 DATA WGAUSS(88)/ .0157260304760247193D0/
6425 DATA WGAUSS(89)/ .0134630478967186426D0/
6426 DATA WGAUSS(90)/ .0111681394601311288D0/
6427 DATA WGAUSS(91)/ .00884675982636394772D0/
6428 DATA WGAUSS(92)/ .00650445796897836286D0/
6429 DATA WGAUSS(93)/ .00414703326056246764D0/
6430 DATA WGAUSS(94)/ .00178328072169643295D0/
6431 DATA WGAUSS(95)/ .0486909570091397204D0/
6432 DATA WGAUSS(96)/ .0485754674415034269D0/
6433 DATA WGAUSS(97)/ .0483447622348029572D0/
6434 DATA WGAUSS(98)/ .0479993885964583077D0/
6435 DATA WGAUSS(99)/ .0475401657148303087D0/
6436 DATA WGAUSS(100)/ .0469681828162100173D0/
6437 DATA WGAUSS(101)/ .0462847965813144172D0/
6438 DATA WGAUSS(102)/ .0454916279274181445D0/
6439 DATA WGAUSS(103)/ .0445905581637565631D0/
6440 DATA WGAUSS(104)/ .0435837245293234534D0/
6441 DATA WGAUSS(105)/ .0424735151236535890D0/
6442 DATA WGAUSS(106)/ .0412625632426235286D0/
6443 DATA WGAUSS(107)/ .0399537411327203414D0/
6444 DATA WGAUSS(108)/ .0385501531786156291D0/
6445 DATA WGAUSS(109)/ .0370551285402400460D0/
6446 DATA WGAUSS(110)/ .0354722132568823838D0/
6447 DATA WGAUSS(111)/ .0338051618371416094D0/
6448 DATA WGAUSS(112)/ .0320579283548515535D0/
6449 DATA WGAUSS(113)/ .0302346570724024789D0/
6450 DATA WGAUSS(114)/ .0283396726142594832D0/
6451 DATA WGAUSS(115)/ .0263774697150546587D0/
6452 DATA WGAUSS(116)/ .0243527025687108733D0/
6453 DATA WGAUSS(117)/ .0222701738083832542D0/
6454 DATA WGAUSS(118)/ .0201348231535302094D0/
6455 DATA WGAUSS(119)/ .0179517157756973431D0/
6456 DATA WGAUSS(120)/ .0157260304760247193D0/
6457 DATA WGAUSS(121)/ .0134630478967186426D0/
6458 DATA WGAUSS(122)/ .0111681394601311288D0/
6459 DATA WGAUSS(123)/ .00884675982636394772D0/
6460 DATA WGAUSS(124)/ .00650445796897836286D0/
6461 DATA WGAUSS(125)/ .00414703326056246764D0/
6462 DATA WGAUSS(126)/ .00178328072169643295D0/
6463C
6464 W1 = PGAM(4,1)
6465 W2 = PGAM(4,2)
6466 bmin = b1 - 2.D0*RADSRC(1)
6467 IF (RADSRC(1) .GT. bmin) THEN
6468 bmin = RADSRC(1)
6469 ENDIF
6470 bmax = b1 + 2.D0 * RADSRC(1)
6471
6472 XINT = 0.D0
6473 DO 100 N=1,6
6474 XINT2 = XINT
6475 XINT = 0.D0
6476 DO 200 I=2**N-1,2**(N+1)-2
6477 b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
6478 XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
6479 & * PHO_GGFNUC(W2,b2,GAMSRC(2))
6480 & * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
6481 XINT = XINT +WGAUSS(I) * b2 * XINT3
6482 200 CONTINUE
6483 XINT = (bmax-bmin)/2.D0*XINT
6484 IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
6485 100 CONTINUE
6486 WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
6487 300 CONTINUE
6488
6489 PHO_GGFAUX = XINT
6490
6491 END
6492
6493*$ CREATE PHO_GGFNUC.FOR
6494*COPY PHO_GGFNUC
6495CDECK ID>, PHO_GGFNUC
6496 DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
6497C**********************************************************************
6498C
6499C differential photonnumber for a nucleus (geometrical model)
6500C (without form factor)
6501C
6502C*********************************************************************
6503 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6504 SAVE
6505
6506 PARAMETER (PI = 3.14159265359D0)
6507
6508 WGamma = W/Gamma
6509 Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
6510
6511 PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
6512
6513 END
6514
6515*$ CREATE PHO_GHHIOF.FOR
6516*COPY PHO_GHHIOF
6517CDECK ID>, PHO_GHHIOF
6518 SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
6519C**********************************************************************
6520C
6521C interface to call PHOJET (variable energy run) for
6522C gamma-hadron collisions in heavy ion collisions
6523C (form factor approach)
6524C
6525C input: EEN LAB system energy per nucleon
6526C NA atomic number of ion/hadron
6527C NZ charge number of ion/hadron
6528C NEVENT number of events to generate
6529C from /LEPCUT/:
6530C YMIN1,2 lower limit of Y
6531C (energy fraction taken by photon from hadron)
6532C YMAX1,2 upper cutoff for Y, necessary to avoid
6533C underflows
6534C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
6535C Q2MAX1,2 maximum Q**2 of photons (if necessary,
6536C corrected according size of hadron)
6537C
6538C**********************************************************************
6539 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6540 SAVE
6541
6542 PARAMETER ( PI = 3.14159265359D0 )
6543
6544C input/output channels
6545 INTEGER LI,LO
6546 COMMON /POINOU/ LI,LO
6547C model switches and parameters
6548 CHARACTER*8 MDLNA
6549 INTEGER ISWMDL,IPAMDL
6550 DOUBLE PRECISION PARMDL
6551 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
6552C event debugging information
6553 INTEGER NMAXD
6554 PARAMETER (NMAXD=100)
6555 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
6556 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6557 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
6558 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6559C photon flux kinematics and cuts
6560 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
6561 & YMIN1,YMAX1,YMIN2,YMAX2,
6562 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6563 & THMIN1,THMAX1,THMIN2,THMAX2
6564 INTEGER ITAG1,ITAG2
6565 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
6566 & YMIN1,YMAX1,YMIN2,YMAX2,
6567 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6568 & THMIN1,THMAX1,THMIN2,THMAX2,
6569 & ITAG1,ITAG2
6570C gamma-lepton or gamma-hadron vertex information
6571 INTEGER IGHEL,IDPSRC,IDBSRC
6572 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6573 & RADSRC,AMSRC,GAMSRC
6574 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6575 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6576 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6577C nucleon-nucleus / nucleus-nucleus interface to DPMJET
6578 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
6579 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
6580 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
6581 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
6582
6583C standard particle data interface
6584 INTEGER NMXHEP
6585
6586 PARAMETER (NMXHEP=4000)
6587
6588 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
6589 DOUBLE PRECISION PHEP,VHEP
6590 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
6591 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
6592 & VHEP(4,NMXHEP)
6593C extension to standard particle data interface (PHOJET specific)
6594 INTEGER IMPART,IPHIST,ICOLOR
6595 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
6596
6597C event weights and generated cross section
6598 INTEGER IPOWGC,ISWCUT,IVWGHT
6599 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
6600 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
6601 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
6602
6603 DIMENSION P1(4),P2(4)
6604 DIMENSION NITERS(2),ITRW(2)
6605
6606 WRITE(LO,'(2(/1X,A))')
6607 & 'PHO_GHHIOF: gamma-hadron event generation',
6608 & '-----------------------------------------'
6609C hadron size and mass
6610 FM2GEV = 5.07D0
6611 HIMASS = DBLE(NA)*0.938D0
6612 HIMA2 = HIMASS**2
6613 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
6614 ALPHA = DBLE(NZ**2)/137.D0
6615 AMP = 0.938D0
6616 AMP2 = AMP**2
6617C correct Q2MAX1,2 according to hadron size
6618 Q2MAXH = 2.D0/HIRADI**2
6619 Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
6620 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
6621 IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
6622 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
6623C total hadron / heavy ion energy
6624 EE = EEN*DBLE(NA)
6625 GAMMA = EE/HIMASS
6626C setup /POFSRC/
6627 GAMSRC(1) = GAMMA
6628 GAMSRC(2) = GAMMA
6629 RADSRC(1) = HIRADI
6630 RADSRC(2) = HIRADI
6631 AMSRC(1) = HIMASS
6632 AMSRC(2) = HIMASS
6633C check cuts on photon-hadron mass
6634 IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
6635 YMI = ECMIN
6636 ECMIN = PARMDL(46)/PARMDL(45)+0.1D0
6637 WRITE(LO,'(/1X,A,2E12.5)')
6638 & 'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
6639 ENDIF
6640C check kinematic limitations
6641 YMI = ECMIN**2/(4.D0*EE*EEN)
6642 IF(YMIN1.LT.YMI) THEN
6643 WRITE(LO,'(/1X,A,2E12.5)')
6644 & 'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
6645 YMIN1 = YMI
6646 ELSE IF(YMIN1.GT.YMI) THEN
6647 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6648 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
6649 & ' INSTEAD OF',YMIN1
6650 ENDIF
6651 IF(YMIN2.LT.YMI) THEN
6652 WRITE(LO,'(/1X,A,2E12.5)')
6653 & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
6654 YMIN2 = YMI
6655 ELSE IF(YMIN2.GT.YMI) THEN
6656 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6657 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
6658 & ' INSTEAD OF',YMIN2
6659 ENDIF
6660C kinematic limitation
6661 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6662 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6663C debug output
6664 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
6665 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
6666 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
6667 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
6668 & Q2MAX1
6669 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
6670 & Q2MAX2
6671 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
6672 & YMAX1
6673 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
6674 & YMAX2
6675 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
6676 & 2.D0*EEN,2.D0*EE
6677 WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON ',ECMIN,
6678 & ECMAX
6679 WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
6680 & PARMDL(175)
6681 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
6682 IF(Q2LOW1.GE.Q2MAX1) THEN
6683 WRITE(LO,'(/1X,A,2E12.4)')
6684 & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
6685 CALL PHO_ABORT
6686 ENDIF
6687 IF(Q2LOW2.GE.Q2MAX2) THEN
6688 WRITE(LO,'(/1X,A,2E12.4)')
6689 & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
6690 CALL PHO_ABORT
6691 ENDIF
6692C hadron numbers set to 0
6693 IDPSRC(1) = 0
6694 IDPSRC(2) = 0
6695 IDBSRC(1) = 0
6696 IDBSRC(2) = 0
6697C
6698 Max_tab = 100
6699 YMAX = YMAX1
6700 YMIN = YMIN1
6701 XMAX = LOG(YMAX)
6702 XMIN = LOG(YMIN)
6703 XDEL = XMAX-XMIN
6704 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6705 DO 100 I=1,Max_tab
6706 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6707 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6708 IF(Q2LOW1.GE.Q2MAX1) THEN
6709 WRITE(LO,'(/1X,A,2E12.4)')
6710 & 'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
6711 YMAX1 = MIN(Y1,YMAX1)
6712 GOTO 101
6713 ENDIF
6714 100 CONTINUE
6715 101 CONTINUE
6716 YMAX = YMAX2
6717 YMIN = YMIN2
6718 XMAX = LOG(YMAX)
6719 XMIN = LOG(YMIN)
6720 XDEL = XMAX-XMIN
6721 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6722 DO 102 I=1,Max_tab
6723 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6724 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
6725 IF(Q2LOW2.GE.Q2MAX2) THEN
6726 WRITE(LO,'(/1X,A,2E12.4)')
6727 & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
6728 YMAX2 = MIN(Y1,YMAX2)
6729 GOTO 103
6730 ENDIF
6731 102 CONTINUE
6732 103 CONTINUE
6733C
6734 X1MAX = LOG(YMAX1)
6735 X1MIN = LOG(YMIN1)
6736 X1DEL = X1MAX-X1MIN
6737 X2MAX = LOG(YMAX2)
6738 X2MIN = LOG(YMIN2)
6739 X2DEL = X2MAX-X2MIN
6740 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
6741 FLUX = 0.D0
6742 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
6743 & 'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
6744 DO 105 I=1,Max_tab
6745 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
6746 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6747 FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
6748 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
6749 FLUX = FLUX+Y1*FF
6750 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
6751 105 CONTINUE
6752 FLUX = FLUX*DELLY
6753 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
6754 & 'PHO_GHHIOF: integrated flux (one side):',FLUX
6755C
6756C photon
6757 EGAM = MAX(YMAX1,YMAX2)*EE
6758 P1(1) = 0.D0
6759 P1(2) = 0.D0
6760 P1(3) = EGAM
6761 P1(4) = EGAM
6762C hadron
6763 P2(1) = 0.D0
6764 P2(2) = 0.D0
6765 P2(3) = -SQRT(EEN**2-AMP2)
6766 P2(4) = EEN
6767 CALL PHO_SETPAR(1,22,0,0.D0)
6768 CALL PHO_SETPAR(2,2212,0,0.D0)
6769 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
6770C
6771 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6772 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6773 Y1 = YMIN1
6774 Y2 = YMIN2
6775 WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
6776 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6777 WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
6778 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6779C
6780 IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
6781 IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
6782C
6783 FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
6784 & /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
6785C
6786 CALL PHO_PHIST(-1,SIGMAX)
6787 CALL PHO_LHIST(-1,SIGMAX)
6788C
6789C generation of events, flux calculation
6790
6791 AY1 = 0.D0
6792 AY2 = 0.D0
6793 AYS1 = 0.D0
6794 AYS2 = 0.D0
6795 Q21MIN = 1.D30
6796 Q22MIN = 1.D30
6797 Q21MAX = 0.D0
6798 Q22MAX = 0.D0
6799 Q21AVE = 0.D0
6800 Q22AVE = 0.D0
6801 Q21AV2 = 0.D0
6802 Q22AV2 = 0.D0
6803 YY1MIN = 1.D30
6804 YY2MIN = 1.D30
6805 YY1MAX = 0.D0
6806 YY2MAX = 0.D0
6807 NITER = NEVENT
6808 NITERS(1) = 0
6809 NITERS(2) = 0
6810 ITRY = 0
6811 ITRW(1) = 0
6812 ITRW(2) = 0
6813 DO 200 I=1,NITER
6814C sample y1, y2
6815 150 CONTINUE
6816 ITRY = ITRY+1
6817 175 CONTINUE
6818C
6819C select side of photon emission
6820 IF(DT_RNDM(AY1).LT.FAC12) THEN
6821 ITRW(1) = ITRW(1)+1
6822C select Y1
6823 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
6824 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
6825 IF(Q2LOW1.GE.Q2MAX1) GOTO 175
6826 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
6827 WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
6828 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6829 IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6830 & 'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
6831 IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
6832C sample Q2
6833 IF(IPAMDL(174).EQ.1) THEN
6834 YEFF = 1.D0+(1.D0-Y1)**2
6835 185 CONTINUE
6836 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
6837 WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
6838 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
6839 ELSE
6840 Q2P1 = Q2LOW1
6841 ENDIF
6842C impact parameter
6843 GAIMP(1) = 1.D0/SQRT(Q2P1)
6844C form factor (squared)
6845 FF2 = 1.D0
6846 IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
6847 IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
6848C photon data
6849 GYY(1) = Y1
6850 GQ2(1) = Q2P1
6851
6852C
6853C incoming hadron 1
6854 PINI(1,1) = 0.D0
6855 PINI(2,1) = 0.D0
6856 PINI(3,1) = SQRT(EE**2-AMP2)
6857 PINI(4,1) = EE
6858 PINI(5,1) = AMP
6859C outgoing hadron 1
6860 YQ2 = SQRT((1.D0-Y1)*Q2P1)
6861 Q2E = Q2P1/(4.D0*EE)
6862 E1Y = EE*(1.D0-Y1)
6863 CALL PHO_SFECFE(SIF,COF)
6864 PFIN(1,1) = YQ2*COF
6865 PFIN(2,1) = YQ2*SIF
6866 PFIN(3,1) = E1Y-Q2E
6867 PFIN(4,1) = E1Y+Q2E
6868 PFIN(5,1) = 0.D0
6869 PFPHI(1) = ATAN2(COF,SIF)
6870 PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
6871C incoming hadron 2
6872 PINI(1,2) = 0.D0
6873 PINI(2,2) = 0.D0
6874 PINI(3,2) = -SQRT(EE**2-AMP2)
6875 PINI(4,2) = EE
6876 PINI(5,2) = AMP
6877C scattering photon
6878 P1(1) = -PFIN(1,1)
6879 P1(2) = -PFIN(2,1)
6880 P1(3) = PINI(3,1)-PFIN(3,1)
6881 P1(4) = PINI(4,1)-PFIN(4,1)
6882C scattering hadron
6883 P2(1) = 0.D0
6884 P2(2) = 0.D0
6885 P2(3) = -SQRT(EEN**2-AMP2)
6886 P2(4) = EEN
6887 ISIDE = 1
6888C
6889 ELSE
6890C
6891 ITRW(2) = ITRW(2)+1
6892C select Y2
6893 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
6894 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
6895 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
6896 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
6897 WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
6898 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6899 IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6900 & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
6901 IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
6902C sample Q2
6903 IF(IPAMDL(174).EQ.1) THEN
6904 YEFF = 1.D0+(1.D0-Y2)**2
6905 186 CONTINUE
6906 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
6907 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
6908 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
6909 ELSE
6910 Q2P2 = Q2LOW2
6911 ENDIF
6912C impact parameter
6913 GAIMP(2) = 1.D0/SQRT(Q2P2)
6914C form factor (squared)
6915 FF2 = 1.D0
6916 IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
6917 IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
6918C photon data
6919 GYY(2) = Y2
6920 GQ2(2) = Q2P2
6921
6922C
6923C incoming hadron 1
6924 PINI(1,1) = 0.D0
6925 PINI(2,1) = 0.D0
6926 PINI(3,1) = SQRT(EE**2-AMP2)
6927 PINI(4,1) = EE
6928 PINI(5,1) = AMP
6929C incoming hadron 2
6930 PINI(1,2) = 0.D0
6931 PINI(2,2) = 0.D0
6932 PINI(3,2) = -SQRT(EE**2-AMP2)
6933 PINI(4,2) = EE
6934 PINI(5,2) = AMP
6935C outgoing hadron 2
6936 YQ2 = SQRT((1.D0-Y2)*Q2P2)
6937 Q2E = Q2P2/(4.D0*EE)
6938 E1Y = EE*(1.D0-Y2)
6939 CALL PHO_SFECFE(SIF,COF)
6940 PFIN(1,2) = YQ2*COF
6941 PFIN(2,2) = YQ2*SIF
6942 PFIN(3,2) = -E1Y+Q2E
6943 PFIN(4,2) = E1Y+Q2E
6944 PFIN(5,2) = 0.D0
6945 PFPHI(2) = ATAN2(COF,SIF)
6946 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
6947C scattering hadron
6948 P2(1) = 0.D0
6949 P2(2) = 0.D0
6950 P2(3) = SQRT(EEN**2-AMP2)
6951 P2(4) = EEN
6952C scattering photon
6953 P1(1) = -PFIN(1,2)
6954 P1(2) = -PFIN(2,2)
6955 P1(3) = PINI(3,2)-PFIN(3,2)
6956 P1(4) = PINI(4,2)-PFIN(4,2)
6957 ISIDE = 2
6958 ENDIF
6959C ECMS cut
6960 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
6961 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
6962 IF(GGECM.LT.0.1D0) GOTO 175
6963 GGECM = SQRT(GGECM)
6964 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
6965C
6966 PGAM(1,1) = P1(1)
6967 PGAM(2,1) = P1(2)
6968 PGAM(3,1) = P1(3)
6969 PGAM(4,1) = P1(4)
6970 PGAM(5,1) = -SQRT(Q2P1)
6971 PGAM(1,2) = P2(1)
6972 PGAM(2,2) = P2(2)
6973 PGAM(3,2) = P2(3)
6974 PGAM(4,2) = P2(4)
6975 PGAM(5,2) = -SQRT(Q2P2)
6976 CALL PHO_PRESEL(5,IREJ)
6977C photon helicities
6978 IGHEL(1) = 1
6979 IGHEL(2) = 1
6980C user cuts
6981 IF(IREJ.NE.0) GOTO 175
6982C event generation
6983 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
6984 IF(IREJ.NE.0) GOTO 150
6985C cut on diffractive mass
6986 DO 250 K=1,NHEP
6987 IF(ISTHEP(K).EQ.30) THEN
6988 GHDIFF = PHEP(1,K)
6989 IF(GHDIFF.GE.PARMDL(175)) THEN
6990 GOTO 251
6991 ELSE
6992 GOTO 150
6993 ENDIF
6994 ENDIF
6995 250 CONTINUE
6996 WRITE(LO,'(/,1X,A)')
6997 & 'PHO_GHHIOF: no diffractive entry found'
6998 CALL PHO_PREVNT(-1)
6999 GOTO 150
7000 251 CONTINUE
7001C remove quasi-elastically scattered hadron
7002 DO 260 K=1,NHEP
7003 IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7004 XF = ABS(PHEP(3,K)/EEN)
7005 IF(XF.LT.PARMDL(72)) GOTO 150
7006* ISTHEP(K) = 2
7007 GOTO 261
7008 ENDIF
7009 260 CONTINUE
7010 261 CONTINUE
7011C
7012C statistics
7013
7014 NITERS(ISIDE) = NITERS(ISIDE)+1
7015 IF(ISIDE.EQ.1) THEN
7016
7017 AY1 = AY1+Y1
7018 AYS1 = AYS1+Y1*Y1
7019 Q21AVE = Q21AVE+Q2P1
7020 Q21AV2 = Q21AV2+Q2P1*Q2P1
7021 Q21MIN = MIN(Q21MIN,Q2P1)
7022 Q21MAX = MAX(Q21MAX,Q2P1)
7023 YY1MIN = MIN(YY1MIN,Y1)
7024 YY1MAX = MAX(YY1MAX,Y1)
7025 ELSE
7026
7027 AY2 = AY2+Y2
7028 AYS2 = AYS2+Y2*Y2
7029 Q22AVE = Q22AVE+Q2P2
7030 Q22AV2 = Q22AV2+Q2P2*Q2P2
7031 Q22MIN = MIN(Q22MIN,Q2P2)
7032 Q22MAX = MAX(Q22MAX,Q2P2)
7033 YY2MIN = MIN(YY2MIN,Y2)
7034 YY2MAX = MAX(YY2MAX,Y2)
7035 ENDIF
7036C histograms
7037 CALL PHO_PHIST(1,HSWGHT(0))
7038 CALL PHO_LHIST(1,HSWGHT(0))
7039 200 CONTINUE
7040C
7041 WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
7042 WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
7043 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
7044 WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
7045 AY1 = AY1/DBLE(MAX(NITERS(1),1))
7046 AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
7047 DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
7048 AY2 = AY2/DBLE(MAX(NITERS(2),1))
7049 AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
7050 DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
7051 Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
7052 Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
7053 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
7054 Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
7055 Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
7056 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
7057 WGMAX = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
7058 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
7059 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7060C output of statistics, histograms
7061 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7062 &'=========================================================',
7063 &' ***** simulated cross section: ',WEIGHT,' mb *****',
7064 &'========================================================='
7065 WRITE(LO,'(//1X,A,/3X,6I12)')
7066 & 'PHO_GHHIOF:SUMMARY: NITER, NITERS1/2, ITRY, ITRW1,2',
7067 & NITER,NITERS,ITRY,ITRW
7068 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7069 & WGY,WEIGHT
7070 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
7071 & AY1,DAY1
7072 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
7073 & AY2,DAY2
7074 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
7075 & YY1MIN,YY1MAX
7076 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
7077 & YY2MIN,YY2MAX
7078 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
7079 & Q21AVE,Q21AV2
7080 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
7081 & Q21MIN,Q21MAX
7082 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
7083 & Q22AVE,Q22AV2
7084 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
7085 & Q22MIN,Q22MAX
7086C
7087 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7088 IF(NITER.GT.1) THEN
7089 CALL PHO_PHIST(-2,WEIGHT)
7090 CALL PHO_LHIST(-2,WEIGHT)
7091 ELSE
7092 WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
7093 ENDIF
7094
7095 END
7096
7097*$ CREATE PHO_GHHIAS.FOR
7098*COPY PHO_GHHIAS
7099CDECK ID>, PHO_GHHIAS
7100 SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
7101C**********************************************************************
7102C
7103C interface to call PHOJET (variable energy run) for
7104C gamma-hadron collisions in heavy ion - hadron
7105C collisions (form factor approach)
7106C
7107C input: EEP LAB system energy of proton (GeV)
7108C EEN LAB system energy per nucleon (GeV)
7109C NA atomic number of ion/hadron
7110C NZ charge number of ion/hadron
7111C NEVENT number of events to generate
7112C from /LEPCUT/:
7113C YMIN2 lower limit of Y
7114C (energy fraction taken by photon from hadron)
7115C YMAX2 upper cutoff for Y, necessary to avoid
7116C underflows
7117C Q2MIN2 minimum Q**2 of photons (should be set to 0)
7118C Q2MAX2 maximum Q**2 of photons (if necessary,
7119C corrected according size of hadron)
7120C
7121C**********************************************************************
7122 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7123 SAVE
7124
7125 PARAMETER ( PI = 3.14159265359D0 )
7126
7127C input/output channels
7128 INTEGER LI,LO
7129 COMMON /POINOU/ LI,LO
7130C model switches and parameters
7131 CHARACTER*8 MDLNA
7132 INTEGER ISWMDL,IPAMDL
7133 DOUBLE PRECISION PARMDL
7134 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7135C event debugging information
7136 INTEGER NMAXD
7137 PARAMETER (NMAXD=100)
7138 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7139 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7140 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7141 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7142C photon flux kinematics and cuts
7143 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
7144 & YMIN1,YMAX1,YMIN2,YMAX2,
7145 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7146 & THMIN1,THMAX1,THMIN2,THMAX2
7147 INTEGER ITAG1,ITAG2
7148 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
7149 & YMIN1,YMAX1,YMIN2,YMAX2,
7150 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7151 & THMIN1,THMAX1,THMIN2,THMAX2,
7152 & ITAG1,ITAG2
7153C gamma-lepton or gamma-hadron vertex information
7154 INTEGER IGHEL,IDPSRC,IDBSRC
7155 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
7156 & RADSRC,AMSRC,GAMSRC
7157 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
7158 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
7159 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
7160C nucleon-nucleus / nucleus-nucleus interface to DPMJET
7161 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
7162 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
7163 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
7164 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
7165
7166C standard particle data interface
7167 INTEGER NMXHEP
7168
7169 PARAMETER (NMXHEP=4000)
7170
7171 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
7172 DOUBLE PRECISION PHEP,VHEP
7173 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
7174 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
7175 & VHEP(4,NMXHEP)
7176C extension to standard particle data interface (PHOJET specific)
7177 INTEGER IMPART,IPHIST,ICOLOR
7178 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
7179
7180C event weights and generated cross section
7181 INTEGER IPOWGC,ISWCUT,IVWGHT
7182 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
7183 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
7184 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
7185
7186 DIMENSION P1(4),P2(4)
7187
7188 WRITE(LO,'(2(/1X,A))')
7189 & 'PHO_GHHIAS: hadron-gamma event generation',
7190 & '-----------------------------------------'
7191C hadron size and mass
7192 FM2GEV = 5.07D0
7193 HIMASS = DBLE(NA)*0.938D0
7194 HIMA2 = HIMASS**2
7195 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
7196 ALPHA = DBLE(NZ**2)/137.D0
7197 AMP = 0.938D0
7198 AMP2 = AMP**2
7199C correct Q2MAX2 according to hadron size
7200 Q2MAXH = 2.D0/HIRADI**2
7201 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
7202 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
7203C total hadron / heavy ion energy
7204 EE = EEN*DBLE(NA)
7205 GAMMA = EE/HIMASS
7206C setup /POFSRC/
7207 GAMSRC(2) = GAMMA
7208 RADSRC(2) = HIRADI
7209 AMSRC(2) = HIMASS
7210C check kinematic limitations
7211 YMI = ECMIN**2/(4.D0*EE*EEP)
7212 IF(YMIN2.LT.YMI) THEN
7213 WRITE(LO,'(/1X,A,2E12.5)')
7214 & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
7215 YMIN2 = YMI
7216 ELSE IF(YMIN2.GT.YMI) THEN
7217 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
7218 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
7219 & ' INSTEAD OF',YMIN2
7220 ENDIF
7221C kinematic limitation
7222 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7223C debug output
7224 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
7225 WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV) ',HIMASS
7226 WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION RADIUS (GeV**-1) ',HIRADI
7227 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
7228 & Q2MAX2
7229 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
7230 & YMAX2
7231 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
7232 & 2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
7233 WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON ',ECMIN,
7234 & ECMAX
7235 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
7236 IF(Q2LOW2.GE.Q2MAX2) THEN
7237 WRITE(LO,'(/1X,A,2E12.4)')
7238 & 'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
7239 CALL PHO_ABORT
7240 ENDIF
7241C hadron numbers set to 0
7242 IDPSRC(1) = 0
7243 IDPSRC(2) = 0
7244 IDBSRC(1) = 0
7245 IDBSRC(2) = 0
7246C
7247 Max_tab = 100
7248 YMAX = YMAX2
7249 YMIN = YMIN2
7250 XMAX = LOG(YMAX)
7251 XMIN = LOG(YMIN)
7252 XDEL = XMAX-XMIN
7253 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
7254 DO 102 I=1,Max_tab
7255 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
7256 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
7257 IF(Q2LOW2.GE.Q2MAX2) THEN
7258 WRITE(LO,'(/1X,A,2E12.4)')
7259 & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
7260 YMAX2 = MIN(Y1,YMAX2)
7261 GOTO 103
7262 ENDIF
7263 102 CONTINUE
7264 103 CONTINUE
7265C
7266 X2MAX = LOG(YMAX2)
7267 X2MIN = LOG(YMIN2)
7268 X2DEL = X2MAX-X2MIN
7269 DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
7270 FLUX = 0.D0
7271 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
7272 & 'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
7273 DO 105 I=1,Max_tab
7274 Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
7275 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
7276 FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
7277 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
7278 FLUX = FLUX+Y2*FF
7279 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
7280 105 CONTINUE
7281 FLUX = FLUX*DELLY
7282 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
7283 & 'PHO_GHHIAS: integrated flux:',FLUX
7284C
7285C hadron
7286 P1(1) = 0.D0
7287 P1(2) = 0.D0
7288 P1(3) = -SQRT(EEP**2-AMP2)
7289 P1(4) = EEP
7290C photon
7291 EGAM = YMAX2*EE
7292 P2(1) = 0.D0
7293 P2(2) = 0.D0
7294 P2(3) = EGAM
7295 P2(4) = EGAM
7296 CALL PHO_SETPAR(1,2212,0,0.D0)
7297 CALL PHO_SETPAR(2,22,0,0.D0)
7298 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
7299C
7300 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7301 Y2 = YMIN2
7302 WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
7303 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7304C
7305 CALL PHO_PHIST(-1,SIGMAX)
7306 CALL PHO_LHIST(-1,SIGMAX)
7307C
7308C generation of events, flux calculation
7309
7310 AY1 = 0.D0
7311 AY2 = 0.D0
7312 AYS1 = 0.D0
7313 AYS2 = 0.D0
7314 Q22MIN = 1.D30
7315 Q22MAX = 0.D0
7316 Q22AVE = 0.D0
7317 Q22AV2 = 0.D0
7318 YY2MIN = 1.D30
7319 YY2MAX = 0.D0
7320 NITER = NEVENT
7321 NITERS = 0
7322 ITRY = 0
7323 ITRW = 0
7324 DO 200 I=1,NITER
7325C sample photon flux
7326 150 CONTINUE
7327 ITRY = ITRY+1
7328 175 CONTINUE
7329C
7330 ITRW = ITRW+1
7331C select Y2
7332 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
7333 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
7334 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
7335 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
7336 WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
7337 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7338 IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
7339 & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
7340 IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
7341C sample Q2
7342 IF(IPAMDL(174).EQ.1) THEN
7343 YEFF = 1.D0+(1.D0-Y2)**2
7344 186 CONTINUE
7345 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
7346 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
7347 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
7348 ELSE
7349 Q2P2 = Q2LOW2
7350 ENDIF
7351C impact parameter
7352 GAIMP(2) = 1.D0/SQRT(Q2P2)
7353C form factor (squared)
7354 FF2 = 1.D0
7355 IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
7356 IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
7357C photon data
7358 GYY(2) = Y2
7359 GQ2(2) = Q2P2
7360
7361C
7362C incoming hadron 1
7363 PINI(1,1) = 0.D0
7364 PINI(2,1) = 0.D0
7365 PINI(3,1) = SQRT(EEP**2-AMP2)
7366 PINI(4,1) = EEP
7367 PINI(5,1) = AMP
7368C incoming hadron 2
7369 PINI(1,2) = 0.D0
7370 PINI(2,2) = 0.D0
7371 PINI(3,2) = -SQRT(EE**2-AMP2)
7372 PINI(4,2) = EE
7373 PINI(5,2) = AMP
7374C outgoing hadron 2
7375 YQ2 = SQRT((1.D0-Y2)*Q2P2)
7376 Q2E = Q2P2/(4.D0*EE)
7377 E1Y = EE*(1.D0-Y2)
7378 CALL PHO_SFECFE(SIF,COF)
7379 PFIN(1,2) = YQ2*COF
7380 PFIN(2,2) = YQ2*SIF
7381 PFIN(3,2) = -E1Y+Q2E
7382 PFIN(4,2) = E1Y+Q2E
7383 PFIN(5,2) = 0.D0
7384 PFPHI(2) = ATAN2(COF,SIF)
7385 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
7386C scattering hadron
7387 P1(1) = 0.D0
7388 P1(2) = 0.D0
7389 P1(3) = SQRT(EEP**2-AMP2)
7390 P1(4) = EEP
7391 Q2P1 = AMP2
7392C scattering photon
7393 P2(1) = -PFIN(1,2)
7394 P2(2) = -PFIN(2,2)
7395 P2(3) = PINI(3,2)-PFIN(3,2)
7396 P2(4) = PINI(4,2)-PFIN(4,2)
7397 ISIDE = 2
7398C
7399C ECMS cut
7400 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
7401 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
7402 IF(GGECM.LT.0.1D0) GOTO 175
7403 GGECM = SQRT(GGECM)
7404 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
7405C
7406 PGAM(1,1) = P1(1)
7407 PGAM(2,1) = P1(2)
7408 PGAM(3,1) = P1(3)
7409 PGAM(4,1) = P1(4)
7410 PGAM(5,1) = AMP
7411 PGAM(1,2) = P2(1)
7412 PGAM(2,2) = P2(2)
7413 PGAM(3,2) = P2(3)
7414 PGAM(4,2) = P2(4)
7415 PGAM(5,2) = -SQRT(Q2P2)
7416C photon helicities
7417 IGHEL(2) = 1
7418C user cuts
7419 CALL PHO_PRESEL(5,IREJ)
7420 IF(IREJ.NE.0) GOTO 175
7421C event generation
7422 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
7423 IF(IREJ.NE.0) GOTO 150
7424C cut on diffractive mass
7425 DO 250 K=1,NHEP
7426 IF(ISTHEP(K).EQ.30) THEN
7427 GHDIFF = PHEP(1,K)
7428 IF(GHDIFF.GE.PARMDL(175)) THEN
7429 GOTO 251
7430 ELSE
7431 GOTO 150
7432 ENDIF
7433 ENDIF
7434 250 CONTINUE
7435 WRITE(LO,'(/,1X,A)')
7436 & 'PHO_GHHIOF: no diffractive entry found'
7437 CALL PHO_PREVNT(-1)
7438 GOTO 150
7439 251 CONTINUE
7440C remove quasi-elastically scattered hadron
7441 DO 260 K=1,NHEP
7442 IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7443 XF = ABS(PHEP(3,K)/EEN)
7444 IF(XF.LT.PARMDL(72)) GOTO 150
7445* ISTHEP(K) = 2
7446 GOTO 261
7447 ENDIF
7448 260 CONTINUE
7449 261 CONTINUE
7450C
7451C statistics
7452
7453 NITERS = NITERS+1
7454
7455 AY2 = AY2+Y2
7456 AYS2 = AYS2+Y2*Y2
7457 Q22AVE = Q22AVE+Q2P2
7458 Q22AV2 = Q22AV2+Q2P2*Q2P2
7459 Q22MIN = MIN(Q22MIN,Q2P2)
7460 Q22MAX = MAX(Q22MAX,Q2P2)
7461 YY2MIN = MIN(YY2MIN,Y2)
7462 YY2MAX = MAX(YY2MAX,Y2)
7463C histograms
7464 CALL PHO_PHIST(1,HSWGHT(0))
7465 CALL PHO_LHIST(1,HSWGHT(0))
7466 200 CONTINUE
7467C
7468 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7469 WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
7470 AY2 = AY2/DBLE(MAX(NITERS,1))
7471 AYS2 = AYS2/DBLE(MAX(NITERS,1))
7472 DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
7473 Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
7474 Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
7475 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
7476 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7477 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
7478 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7479C output of statistics, histograms
7480 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7481 &'=========================================================',
7482 &' ***** simulated cross section: ',WEIGHT,' mb *****',
7483 &'========================================================='
7484 WRITE(LO,'(//1X,A,/3X,4I12)')
7485 & 'PHO_GHHIOF:SUMMARY: NITER, NITERS, ITRY, ITRW',
7486 & NITER,NITERS,ITRY,ITRW
7487 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7488 & WGY,WEIGHT
7489 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
7490 & AY2,DAY2
7491 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
7492 & YY2MIN,YY2MAX
7493 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
7494 & Q22AVE,Q22AV2
7495 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
7496 & Q22MIN,Q22MAX
7497C
7498 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7499 IF(NITER.GT.1) THEN
7500 CALL PHO_PHIST(-2,WEIGHT)
7501 CALL PHO_LHIST(-2,WEIGHT)
7502 ELSE
7503 WRITE(LO,'(1X,A,I4)')
7504 & 'PHO_GHHIOF: no output of histograms',NITER
7505 ENDIF
7506
7507 END
7508
7509*$ CREATE PHO_FITPAR.FOR
7510*COPY PHO_FITPAR
7511CDECK ID>, PHO_FITPAR
7512 SUBROUTINE PHO_FITPAR(IOUTP)
7513C**********************************************************************
7514C
7515C read input parameters according to PDFs
7516C
7517C**********************************************************************
7518 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7519 SAVE
7520
7521 PARAMETER ( DEFA=-99999.D0,
7522 & DEFB=-100000.D0,
7523 & THOUS=1.D3)
7524
7525C input/output channels
7526 INTEGER LI,LO
7527 COMMON /POINOU/ LI,LO
7528C event debugging information
7529 INTEGER NMAXD
7530 PARAMETER (NMAXD=100)
7531 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7532 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7533 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7534 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7535C model switches and parameters
7536 CHARACTER*8 MDLNA
7537 INTEGER ISWMDL,IPAMDL
7538 DOUBLE PRECISION PARMDL
7539 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7540C global event kinematics and particle IDs
7541 INTEGER IFPAP,IFPAB
7542 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
7543 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
7544C currently activated parton density parametrizations
7545 CHARACTER*8 PDFNAM
7546 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
7547 DOUBLE PRECISION PDFLAM,PDFQ2M
7548 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
7549 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
7550C Reggeon phenomenology parameters
7551 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
7552 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
7553 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
7554 & ALREG,ALREGP,GR(2),B0REG(2),
7555 & GPPP,GPPR,B0PPP,B0PPR,
7556 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
7557C parameters of 2x2 channel model
7558 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
7559 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
7560
7561 DIMENSION INUM(3),IFPAS(2)
7562 CHARACTER*8 CNAME8,PDFNA1,PDFNA2
7563 CHARACTER*10 CNAM10
7564
7565 PARAMETER ( Max_tab = 22 )
7566 DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
7567 REAL XDPtab
7568 INTEGER IDPtab
7569
7570C parameter set for 2212 (GRV94 LO) 2212 (GRV94 LO)
7571 DATA (IDPtab(k, 1),k=1,8) /
7572 & 2212, 5, 6, 0, 2212, 5, 6, 0 /
7573 DATA (XDPtab(k, 1),k=1,27) /
7574 &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7575 &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
7576 &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7577 &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7578 &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7579
7580C parameter set for 2212 (GRV94 LO) -2212 (GRV94 LO)
7581 DATA (IDPtab(k, 2),k=1,8) /
7582 & 2212, 5, 6, 0, -2212, 5, 6, 0 /
7583 DATA (XDPtab(k, 2),k=1,27) /
7584 &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7585 &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
7586 &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7587 &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7588 &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7589
7590C parameter set for 22 (GRV-G LO) 2212 (GRV94 LO)
7591 DATA (IDPtab(k, 3),k=1,8) /
7592 & 22, 5, 3, 0, 2212, 5, 6, 0 /
7593 DATA (XDPtab(k, 3),k=1,27) /
7594 &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7595 &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7596 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7597 &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7598 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7599
7600C parameter set for 22 (GRV-G LO) 22 (GRV-G LO)
7601 DATA (IDPtab(k, 4),k=1,8) /
7602 & 22, 5, 3, 0, 22, 5, 3, 0 /
7603 DATA (XDPtab(k, 4),k=1,27) /
7604 &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7605 &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7606 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7607 &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7608 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7609
7610C parameter set for 22 (GRS-G LO) 2212 (GRV94 LO)
7611 DATA (IDPtab(k, 5),k=1,8) /
7612 & 22, 5, 4, 4, 2212, 5, 6, 0 /
7613 DATA (XDPtab(k, 5),k=1,27) /
7614 &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7615 &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7616 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7617 &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7618 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7619
7620C parameter set for 22 (GRS-G LO) 22 (GRS-G LO)
7621 DATA (IDPtab(k, 6),k=1,8) /
7622 & 22, 5, 4, 4, 22, 5, 4, 4 /
7623 DATA (XDPtab(k, 6),k=1,27) /
7624 &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7625 &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7626 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7627 &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7628 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7629
7630C parameter set for 22 (SaS-1D ) 22 (SaS-1D )
7631 DATA (IDPtab(k, 7),k=1,8) /
7632 & 22, 1, 1, 4, 22, 1, 1, 4 /
7633 DATA (XDPtab(k, 7),k=1,27) /
7634 &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
7635 &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
7636 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7637 &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
7638 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7639
7640C parameter set for 22 (SaS-1M ) 22 (SaS-1M )
7641 DATA (IDPtab(k, 8),k=1,8) /
7642 & 22, 1, 2, 4, 22, 1, 2, 4 /
7643 DATA (XDPtab(k, 8),k=1,27) /
7644 &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
7645 &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
7646 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7647 &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7648 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7649
7650C parameter set for 22 (SaS-2D ) 22 (SaS-2D )
7651 DATA (IDPtab(k, 9),k=1,8) /
7652 & 22, 1, 3, 4, 22, 1, 3, 4 /
7653 DATA (XDPtab(k, 9),k=1,27) /
7654 &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
7655 &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
7656 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7657 &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7658 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7659
7660C parameter set for 22 (SaS-2M ) 22 (SaS-2M )
7661 DATA (IDPtab(k, 10),k=1,8) /
7662 & 22, 1, 4, 4, 22, 1, 4, 4 /
7663 DATA (XDPtab(k, 10),k=1,27) /
7664 &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
7665 &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
7666 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7667 &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+00,1.0000E+00,
7668 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7669
7670C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7671 DATA (IDPtab(k, 11),k=1,8) /
7672 & 22, 3, 1, 3, 2212, 5, 6, 0 /
7673 DATA (XDPtab(k, 11),k=1,27) /
7674 &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7675 &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7676 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7677 &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7678 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7679
7680C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7681 DATA (IDPtab(k, 12),k=1,8) /
7682 & 22, 3, 1, 2, 2212, 5, 6, 0 /
7683 DATA (XDPtab(k, 12),k=1,27) /
7684 &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7685 &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7686 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7687 &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7688 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7689
7690C parameter set for 22 (LAC ) 22 (LAC )
7691 DATA (IDPtab(k, 13),k=1,8) /
7692 & 22, 3, 1, 3, 22, 3, 1, 3 /
7693 DATA (XDPtab(k, 13),k=1,27) /
7694 &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7695 &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7696 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7697 &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7698 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7699
7700C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7701 DATA (IDPtab(k, 14),k=1,8) /
7702 & 22, 3, 1, 2, 22, 3, 1, 2 /
7703 DATA (XDPtab(k, 14),k=1,27) /
7704 &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7705 &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7706 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7707 &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7708 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7709
7710C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7711 DATA (IDPtab(k, 15),k=1,8) /
7712 & 22, 3, 2, 3, 2212, 5, 6, 0 /
7713 DATA (XDPtab(k, 15),k=1,27) /
7714 &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7715 &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7716 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7717 &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7718 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7719
7720C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7721 DATA (IDPtab(k, 16),k=1,8) /
7722 & 22, 3, 2, 2, 2212, 5, 6, 0 /
7723 DATA (XDPtab(k, 16),k=1,27) /
7724 &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7725 &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7726 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7727 &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7728 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7729
7730C parameter set for 22 (LAC ) 22 (LAC )
7731 DATA (IDPtab(k, 17),k=1,8) /
7732 & 22, 3, 2, 3, 22, 3, 2, 3 /
7733 DATA (XDPtab(k, 17),k=1,27) /
7734 &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7735 &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7736 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7737 &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7738 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7739
7740C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7741 DATA (IDPtab(k, 18),k=1,8) /
7742 & 22, 3, 2, 2, 22, 3, 2, 2 /
7743 DATA (XDPtab(k, 18),k=1,27) /
7744 &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7745 &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7746 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7747 &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7748 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7749
7750C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7751 DATA (IDPtab(k, 19),k=1,8) /
7752 & 22, 3, 3, 3, 2212, 5, 6, 0 /
7753 DATA (XDPtab(k, 19),k=1,27) /
7754 &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7755 &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7756 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7757 &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7758 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7759
7760C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7761 DATA (IDPtab(k, 20),k=1,8) /
7762 & 22, 3, 3, 2, 2212, 5, 6, 0 /
7763 DATA (XDPtab(k, 20),k=1,27) /
7764 &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7765 &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7766 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7767 &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7768 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7769
7770C parameter set for 22 (LAC ) 22 (LAC )
7771 DATA (IDPtab(k, 21),k=1,8) /
7772 & 22, 3, 3, 3, 22, 3, 3, 3 /
7773 DATA (XDPtab(k, 21),k=1,27) /
7774 &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7775 &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7776 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7777 &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7778 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7779
7780C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7781 DATA (IDPtab(k, 22),k=1,8) /
7782 & 22, 3, 3, 2, 22, 3, 3, 2 /
7783 DATA (XDPtab(k, 22),k=1,27) /
7784 &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7785 &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7786 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7787 &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7788 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7789
7790 DATA CNAME8 /' '/
7791 DATA CNAM10 /' '/
7792 DATA INIT / 0 /
7793 DATA IFPAS / 0, 0 /
7794
7795 IF((INIT.EQ.1).AND.
7796 & (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
7797
7798 INIT=1
7799 IFPAS(1) = IFPAP(1)
7800 IFPAS(2) = IFPAP(2)
7801
7802C parton distribution functions
7803 CALL PHO_ACTPDF(IFPAP(1),1)
7804 CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7805 CALL PHO_ACTPDF(IFPAP(2),2)
7806 CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7807C initialize alpha_s calculation
7808 DUMMY = PHO_ALPHAS(0.D0,-4)
7809
7810 IF(IDEB(54).GE.0) THEN
7811 WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7812 & IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
7813 WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7814 & IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
7815 ENDIF
7816
7817 IFOUND = 0
7818
7819C load parameter set from internal tables
7820 I1 = 1
7821 I2 = 2
7822 110 CONTINUE
7823
7824 DO I=1,Max_tab
7825 IF((IFPAP(I1).EQ.IDPtab(1,I))
7826 & .AND.(IGRP(I1).EQ.IDPtab(2,I))
7827 & .AND.(ISET(I1).EQ.IDPtab(3,I))
7828 & .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
7829 IF((IFPAP(I2).EQ.IDPtab(5,I))
7830 & .AND.(IGRP(I2).EQ.IDPtab(6,I))
7831 & .AND.(ISET(I2).EQ.IDPtab(7,I))
7832 & .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
7833 WRITE(LO,'(/1X,A)')
7834 & 'PHO_FITPAR: parameter set found in internal table'
7835 ALPOM = XDPtab(1,I)
7836 ALPOMP = XDPtab(2,I)
7837 GP(I1) = XDPtab(3,I)
7838 GP(I2) = XDPtab(4,I)
7839 B0POM(I1) = XDPtab(5,I)
7840 B0POM(I2) = XDPtab(6,I)
7841 ALREG = XDPtab(7,I)
7842 ALREGP = XDPtab(8,I)
7843 GR(I1) = XDPtab(9,I)
7844 GR(I2) = XDPtab(10,I)
7845 B0REG(I1) = XDPtab(11,I)
7846 B0REG(I2) = XDPtab(12,I)
7847 GPPP = XDPtab(13,I)
7848 B0PPP = XDPtab(14,I)
7849 GPPR = XDPtab(15,I)
7850 B0PPR = XDPtab(16,I)
7851 VDMFAC(2*I1-1) = XDPtab(17,I)
7852 VDMFAC(2*I1) = XDPtab(18,I)
7853 VDMFAC(2*I2-1) = XDPtab(19,I)
7854 VDMFAC(2*I2) = XDPtab(20,I)
7855 B0HAR = XDPtab(21,I)
7856 AKFAC = XDPtab(22,I)
7857 PHISUP(I1) = XDPtab(23,I)
7858 PHISUP(I2) = XDPtab(24,I)
7859 RMASS(I1) = XDPtab(25,I)
7860 RMASS(I2) = XDPtab(26,I)
7861 VAR = XDPtab(27,I)
7862 IFOUND = 1
7863 GOTO 1200
7864 ENDIF
7865 ENDIF
7866 ENDDO
7867
7868 IF(I1.EQ.1) THEN
7869 I1 = 2
7870 I2 = 1
7871 GOTO 110
7872 ELSE
7873 WRITE(LO,'(/1X,A)')
7874 & 'PHO_FITPAR: parameter set not found in internal table'
7875 ENDIF
7876
7877 1200 CONTINUE
7878
7879C get parameters of soft cross sections from fitpar.dat
7880 IF(IPAMDL(99).GT.IFOUND) THEN
7881
7882 WRITE(LO,'(/1X,A)')
7883 & 'PHO_FITPAR: loading parameter set from file fitpar.dat'
7884 OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
7885
7886 100 CONTINUE
7887 READ(12,'(A8)',ERR=1020,END=1010) CNAME8
7888 IF(CNAME8.EQ.'STOP') GOTO 1010
7889 IF(CNAME8.EQ.'NEXTDATA') THEN
7890 READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7891 & IDPA1,CNAME8,INUM
7892 IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
7893 & .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
7894 READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7895 & IDPA2,CNAME8,INUM
7896 IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
7897 & (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
7898 WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
7899 READ(12,*) ALPOM,ALPOMP,GP,B0POM
7900 READ(12,*) ALREG,ALREGP,GR,B0REG
7901 READ(12,*) GPPP,B0PPP,GPPR,B0PPR
7902 READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
7903 READ(12,*) B0HAR
7904 READ(12,*) AKFAC
7905 READ(12,*) PHISUP
7906 READ(12,*) RMASS,VAR
7907 IFOUND = 1
7908 GOTO 1100
7909 ENDIF
7910 ENDIF
7911 ENDIF
7912 GOTO 100
7913
7914 1020 CONTINUE
7915 WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
7916 WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
7917 1010 CONTINUE
7918 WRITE(LO,'(/A)')
7919 & ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
7920
7921 1100 CONTINUE
7922 CLOSE(12)
7923
7924 ENDIF
7925
7926C nothing found
7927 IF(IFOUND.EQ.0) THEN
7928 WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
7929 WRITE(LO,'(3(10X,A,/))')
7930 & '(copy fitpar.dat into the working directory and/or',
7931 & ' request the missing parameter set via e-mail from',
7932 & ' ralph.engel@fzk.de)'
7933 STOP
7934 ENDIF
7935
7936 1300 CONTINUE
7937
7938C overwrite parameters with user settings
7939 IF(PARMDL(301).GT.DEFA) THEN
7940 ALPOM = PARMDL(301)
7941 PARMDL(301) = DEFB
7942 ENDIF
7943 IF(PARMDL(302).GT.DEFA) THEN
7944 ALPOMP = PARMDL(302)
7945 PARMDL(302) = DEFB
7946 ENDIF
7947 IF(PARMDL(303).GT.DEFA) THEN
7948 GP(1) = PARMDL(303)
7949 PARMDL(303) = DEFB
7950 ENDIF
7951 IF(PARMDL(304).GT.DEFA) THEN
7952 GP(2) = PARMDL(304)
7953 PARMDL(304) = DEFB
7954 ENDIF
7955 IF(PARMDL(305).GT.DEFA) THEN
7956 B0POM(1) = PARMDL(305)
7957 PARMDL(305) = DEFB
7958 ENDIF
7959 IF(PARMDL(306).GT.DEFA) THEN
7960 B0POM(2) = PARMDL(306)
7961 PARMDL(306) = DEFB
7962 ENDIF
7963 IF(PARMDL(307).GT.DEFA) THEN
7964 ALREG = PARMDL(307)
7965 PARMDL(307) = DEFB
7966 ENDIF
7967 IF(PARMDL(308).GT.DEFA) THEN
7968 ALREGP = PARMDL(308)
7969 PARMDL(308) = DEFB
7970 ENDIF
7971 IF(PARMDL(309).GT.DEFA) THEN
7972 GR(1) = PARMDL(309)
7973 PARMDL(309) = DEFB
7974 ENDIF
7975 IF(PARMDL(310).GT.DEFA) THEN
7976 GR(2) = PARMDL(310)
7977 PARMDL(310) = DEFB
7978 ENDIF
7979 IF(PARMDL(311).GT.DEFA) THEN
7980 B0REG(1) = PARMDL(311)
7981 PARMDL(311) = DEFB
7982 ENDIF
7983 IF(PARMDL(312).GT.DEFA) THEN
7984 B0REG(2) = PARMDL(312)
7985 PARMDL(312) = DEFB
7986 ENDIF
7987 IF(PARMDL(313).GT.DEFA) THEN
7988 GPPP = PARMDL(313)
7989 PARMDL(313) = DEFB
7990 ENDIF
7991 IF(PARMDL(314).GT.DEFA) THEN
7992 B0PPP = PARMDL(314)
7993 PARMDL(314)= DEFB
7994 ENDIF
7995 IF(PARMDL(315).GT.DEFA) THEN
7996 VDMFAC(1) = PARMDL(315)
7997 PARMDL(315)= DEFB
7998 ENDIF
7999 IF(PARMDL(316).GT.DEFA) THEN
8000 VDMFAC(2) = PARMDL(316)
8001 PARMDL(316)= DEFB
8002 ENDIF
8003 IF(PARMDL(317).GT.DEFA) THEN
8004 VDMFAC(3) = PARMDL(317)
8005 PARMDL(317)= DEFB
8006 ENDIF
8007 IF(PARMDL(318).GT.DEFA) THEN
8008 VDMFAC(4) = PARMDL(318)
8009 PARMDL(318)= DEFB
8010 ENDIF
8011 IF(PARMDL(319).GT.DEFA) THEN
8012 B0HAR = PARMDL(319)
8013 PARMDL(319)= DEFB
8014 ENDIF
8015 IF(PARMDL(320).GT.DEFA) THEN
8016 AKFAC = PARMDL(320)
8017 PARMDL(320)= DEFB
8018 ENDIF
8019 IF(PARMDL(321).GT.DEFA) THEN
8020 PHISUP(1) = PARMDL(321)
8021 PARMDL(321)= DEFB
8022 ENDIF
8023 IF(PARMDL(322).GT.DEFA) THEN
8024 PHISUP(2) = PARMDL(322)
8025 PARMDL(322)= DEFB
8026 ENDIF
8027 IF(PARMDL(323).GT.DEFA) THEN
8028 RMASS(1) = PARMDL(323)
8029 PARMDL(323)= DEFB
8030 ENDIF
8031 IF(PARMDL(324).GT.DEFA) THEN
8032 RMASS(2) = PARMDL(324)
8033 PARMDL(324)= DEFB
8034 ENDIF
8035 IF(PARMDL(325).GT.DEFA) THEN
8036 VAR = PARMDL(325)
8037 PARMDL(325)= DEFB
8038 ENDIF
8039 IF(PARMDL(327).GT.DEFA) THEN
8040 GPPR = PARMDL(327)
8041 PARMDL(327)= DEFB
8042 ENDIF
8043 IF(PARMDL(328).GT.DEFA) THEN
8044 B0PPR = PARMDL(328)
8045 PARMDL(328)= DEFB
8046 ENDIF
8047
8048 VDMQ2F(1) = VDMFAC(1)
8049 VDMQ2F(2) = VDMFAC(2)
8050 VDMQ2F(3) = VDMFAC(3)
8051 VDMQ2F(4) = VDMFAC(4)
8052
8053C output of parameter set
8054 IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
8055 WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
8056 & ' -------------------------'
8057 WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8058 & ' ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
8059 & B0POM
8060 WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8061 & ' ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
8062 & B0REG
8063 WRITE(LO,'(4(A,F7.3))')
8064 & ' GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
8065 WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
8066 WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
8067 WRITE(LO,'(A,F8.3)') ' B0HAR:',B0HAR
8068 WRITE(LO,'(A,F8.3)') ' AKFAC:',AKFAC
8069 WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
8070 WRITE(LO,'(A,3F8.3)') ' RMASS:',RMASS,VAR
8071 ENDIF
8072
8073 CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
8074
8075 END
8076
8077*$ CREATE PHO_BORNCS.FOR
8078*COPY PHO_BORNCS
8079CDECK ID>, PHO_BORNCS
8080 SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
8081C*********************************************************************
8082C
8083C calculation of Born graph cross sections and slopes
8084C
8085C input: IP particle combination
8086C IFHARD -1 calculate hard Born graph cross section
8087C 0 take hard Born graph cross section
8088C from interpolation table if available
8089C 1 assume that correct hard cross
8090C sections are already stored in /POSBRN/
8091C XM1,XM2,XM3,XM4 masses of external lines
8092C /GLOCMS/ energy and PT cut-off
8093C /POPREG/ soft and hard parameters
8094C /POSBRN/ input cross sections
8095C /POZBRN/ scaled input values
8096C IFHARD 0 calculate hard input cross sections
8097C 1 assume hard input cross sections exist
8098C
8099C output: ZPOM scaled pomeron cross section
8100C ZIGR scaled reggeon cross section
8101C ZIGHR scaled hard resolved cross section
8102C ZIGHD scaled hard direct cross section
8103C ZIGT1 scaled triple-Pomeron cross section
8104C ZIGT2 scaled triple-Pomeron cross section
8105C ZIGL scaled loop-Pomeron cross section
8106C
8107C*********************************************************************
8108 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8109 SAVE
8110
8111 PARAMETER(ITWO=2,
8112 & ITHREE=3,
8113 & IFOUR=4,
8114 & IFIVE=5,
8115 & FIVE=5.D0,
8116 & THOUS=1.D3,
8117 & EPS=0.01D0,
8118 & DEPS=1.D-30)
8119
8120C input/output channels
8121 INTEGER LI,LO
8122 COMMON /POINOU/ LI,LO
8123C some constants
8124 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
8125 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
8126 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
8127C event debugging information
8128 INTEGER NMAXD
8129 PARAMETER (NMAXD=100)
8130 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8131 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8132 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8133 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8134C model switches and parameters
8135 CHARACTER*8 MDLNA
8136 INTEGER ISWMDL,IPAMDL
8137 DOUBLE PRECISION PARMDL
8138 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8139C names of hard scattering processes
8140 INTEGER Max_pro_1
8141 PARAMETER ( Max_pro_1 = 16 )
8142 CHARACTER*18 PROC
8143 COMMON /POHPRO/ PROC(0:Max_pro_1)
8144C hard cross sections and MC selection weights
8145 INTEGER Max_pro_2
8146 PARAMETER ( Max_pro_2 = 16 )
8147 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
8148 & MH_acc_1,MH_acc_2
8149 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
8150 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
8151 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
8152 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
8153 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
8154 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
8155C interpolation tables for hard cross section and MC selection weights
8156 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
8157 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
8158 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
8159 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
8160 & HQ2a_tab,HQ2b_tab,HEcm_tab
8161 COMMON /POHTAB/
8162 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8163 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8164 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8165 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8166 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
8167 & HEcm_tab(1:Max_tab_E,0:4),
8168 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
8169C Born graph cross sections and slopes
8170 INTEGER Max_pro_3
8171 PARAMETER ( Max_pro_3 = 16 )
8172 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8173 & SIGD1,SIGD2,DSIGH
8174 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8175 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8176C scaled cross sections and slopes
8177 COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8178 & ZIGD1,ZIGD2,
8179 & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8180 COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8181 & ZIGDP(4),ZIGD1(2),ZIGD2(2),
8182 & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8183 & BD1(2),BD2(2)
8184C Reggeon phenomenology parameters
8185 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8186 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8187 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8188 & ALREG,ALREGP,GR(2),B0REG(2),
8189 & GPPP,GPPR,B0PPP,B0PPR,
8190 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8191C parameters of 2x2 channel model
8192 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8193 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8194C data of c.m. system of Pomeron / Reggeon exchange
8195 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8196 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8197 & SIDP,CODP,SIFP,COFP
8198 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8199 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8200 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8201C obsolete cut-off information
8202 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
8203 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
8204C data needed for soft-pt calculation
8205 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
8206 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
8207
8208 COMPLEX*16 CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
8209 & BPOM1,BPOM2,BREG1,BREG2,B0HARD
8210 DIMENSION SCB1(4),SCB2(4),SCG1(4),SCG2(4)
8211 DIMENSION BT14(2),BT24(2),BD4(4)
8212 DIMENSION DSPT(0:Max_pro_2)
8213
8214 DATA XMPOM / 0.766D0 /
8215 DATA CZERO /(0.D0,0.D0)/
8216
8217 CDABS(SS) = ABS(SS)
8218 DCMPLX(X,Y) = CMPLX(X,Y)
8219
8220C debug output
8221 IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
8222 & 'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
8223C scales
8224 CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
8225C
8226C calculate hard input cross sections (output in mb)
8227 IF(IFHARD.NE.1) THEN
8228 IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
8229C double-log interpolation
8230 CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
8231 DO 60 M=0,Max_pro_2
8232 DSIGH(M) = HSig(M)
8233 DSPT(M) = Hdpt(M)
8234 60 CONTINUE
8235 ELSE
8236C new calculation
8237 CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
8238 CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
8239 ENDIF
8240C
8241C save values to calculate soft pt distribution
8242 IF(IP.EQ.1) THEN
8243 VDMQ2F(1) = VDMFAC(1)
8244 VDMQ2F(2) = VDMFAC(2)
8245 VDMQ2F(3) = VDMFAC(3)
8246 VDMQ2F(4) = VDMFAC(4)
8247 ELSE IF(IP.EQ.2) THEN
8248 VDMQ2F(1) = VDMFAC(1)
8249 VDMQ2F(2) = VDMFAC(2)
8250 VDMQ2F(3) = 1.D0
8251 VDMQ2F(4) = 0.D0
8252 ELSE IF(IP.EQ.3) THEN
8253 VDMQ2F(1) = VDMFAC(3)
8254 VDMQ2F(2) = VDMFAC(4)
8255 VDMQ2F(3) = 1.D0
8256 VDMQ2F(4) = 0.D0
8257 ELSE
8258 VDMQ2F(1) = 1.D0
8259 VDMQ2F(2) = 0.D0
8260 VDMQ2F(3) = 1.D0
8261 VDMQ2F(4) = 0.D0
8262 ENDIF
8263C VDM factors
8264 AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
8265 AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
8266 AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
8267 AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
8268 ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
8269 & +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
8270 ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
8271 ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
8272 ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
8273 VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
8274 & +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
8275 DSIGHP = DSPT(9)/VFAC
8276 SIGH = DSIGH(9)/VFAC
8277C extract real part
8278 IF(IPAMDL(1).EQ.0) THEN
8279 DO 50 I=0,Max_pro_2
8280 DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
8281 50 CONTINUE
8282 ENDIF
8283C write out results
8284 IF(IDEB(48).GE.15) THEN
8285 WRITE(LO,'(/1X,A,1P,2E11.3)')
8286 & 'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
8287 DO 200 I=0,Max_pro_2
8288 WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
8289 200 CONTINUE
8290 ENDIF
8291 ENDIF
8292
8293C DPMJET interface: subtract anomalous part
8294 IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
8295 & DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
8296
8297 SCALE = CDABS(DSIGH(15))
8298 IF(SCALE.LT.DEPS) THEN
8299 SIGHD=CZERO
8300 ELSE
8301 SIGHD=DSIGH(15)
8302 ENDIF
8303 SCALE = CDABS(DSIGH(9))
8304 IF(SCALE.LT.DEPS) THEN
8305 SIGHR=CZERO
8306 ELSE
8307 SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
8308 ENDIF
8309
8310C calculate soft input cross sections (output in mb)
8311 SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
8312 IF(IPAMDL(1).EQ.1) THEN
8313C pomeron signature
8314 SP=SS*DCMPLX(0.D0,-1.D0)
8315C reggeon signature
8316 SR=SS*DCMPLX(0.D0,1.D0)
8317 ELSE
8318 SP=SS
8319 SR=SS
8320 ENDIF
8321C coupling constants (mb**1/2)
8322C particle dependent slopes (GeV**-2)
8323 IF(IP.EQ.1) THEN
8324 GP1 = GP(1)
8325 GP2 = GP(2)
8326 GR1 = GR(1)
8327 GR2 = GR(2)
8328 B0POM1 = B0POM(1)
8329 B0POM2 = B0POM(2)
8330 B0REG1 = B0REG(1)
8331 B0REG2 = B0REG(2)
8332 B0HARD = B0HAR
8333 RMASS1 = RMASS(1)
8334 RMASS2 = RMASS(2)
8335 ELSE IF(IP.EQ.2) THEN
8336 GP1 = GP(1)
8337 GP2 = PARMDL(77)
8338 GR1 = GR(1)
8339 GR2 = PARMDL(77)*GPPR/GPPP
8340 B0POM1 = B0POM(1)
8341 B0POM2 = B0PPP
8342 B0REG1 = B0REG(1)
8343 B0REG2 = B0PPR
8344 B0HARD = B0POM1+B0POM2
8345 RMASS1 = RMASS(1)
8346 RMASS2 = XMPOM
8347 ELSE IF(IP.EQ.3) THEN
8348 GP1 = GP(2)
8349 GP2 = PARMDL(77)
8350 GR1 = GR(2)
8351 GR2 = PARMDL(77)*GPPR/GPPP
8352 B0POM1 = B0POM(2)
8353 B0POM2 = B0PPP
8354 B0REG1 = B0REG(2)
8355 B0REG2 = B0PPR
8356 B0HARD = B0POM1+B0POM2
8357 RMASS1 = RMASS(2)
8358 RMASS2 = XMPOM
8359 ELSE IF(IP.EQ.4) THEN
8360 GP1 = PARMDL(77)
8361 GP2 = GP1
8362 GR1 = PARMDL(77)*GPPR/GPPP
8363 GR2 = GR1
8364 B0POM1 = B0PPP
8365 B0POM2 = B0PPP
8366 B0REG1 = B0PPR
8367 B0REG2 = B0PPR
8368 B0HARD = B0POM1+B0POM2
8369 RMASS1 = XMPOM
8370 RMASS2 = XMPOM
8371 ELSE
8372 WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
8373 CALL PHO_ABORT
8374 ENDIF
8375 GP1 = GP1*SCALE1
8376 GP2 = GP2*SCALE2
8377 GR1 = GR1*SCALE1
8378 GR2 = GR2*SCALE2
8379C input slope parameters (GeV**-2)
8380 BPOM1 = B0POM1*SCALB1
8381 BPOM2 = B0POM2*SCALB2
8382 BREG1 = B0REG1*SCALB1
8383 BREG2 = B0REG2*SCALB2
8384C effective slopes
8385 XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
8386 SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
8387 BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
8388 BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
8389 IF(IPAMDL(9).EQ.0) THEN
8390 BHAR = B0HARD
8391 BHAD = B0HARD
8392 ELSE IF(IPAMDL(9).EQ.1) THEN
8393 BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
8394 BHAD = BHAR
8395 ELSE IF(IPAMDL(9).EQ.2) THEN
8396 BHAR = BPOM1+BPOM2
8397 BHAD = BHAR
8398 ELSE
8399 BHAR = BPOM
8400 BHAD = BPOM
8401 ENDIF
8402C input cross section pomeron
8403 SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
8404 SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
8405C save value to calculate soft pt distribution
8406 SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
8407
8408C higher order graphs
8409 VIRT1 = PVIRTP(1)
8410 VIRT2 = PVIRTP(2)
8411C bare/renormalized intercept for enhanced graphs
8412 IF(IPAMDL(8).EQ.0) THEN
8413 DELTAP = ALPOM-1.D0
8414 ELSE
8415 DELTAP = PARMDL(48)-1.D0
8416 ENDIF
8417 SD = ECMP**2
8418 BP1 = 2.D0*BPOM1
8419 BP2 = 2.D0*BPOM2
8420C input cross section high-mass double diffraction
8421 CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
8422 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
8423 SIGL = DCMPLX(SIGTR,0.D0)
8424 BLOO = DCMPLX(BTR,0.D0)
8425C
8426C input cross section high mass diffraction particle 1
8427C first possibility
8428 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8429 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8430 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8431 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8432 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8433 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8434 BP1 = 2.D0*BPOM1*SCALB1
8435 BP2 = 2.D0*BPOM2*SCALB2
8436C input cross section high mass diffraction
8437 CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8438 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8439 SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8440 BTR1(1) = DCMPLX(BTR,0.D0)
8441C second possibility: high-low mass double diffraction
8442 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8443 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8444 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8445 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8446 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8447 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8448 BP1 = 2.D0*BPOM1*SCALB1
8449 BP2 = 2.D0*BPOM2*SCALB2
8450C input cross section high mass diffraction
8451 CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8452 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8453 SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8454 BTR1(2) = DCMPLX(BTR,0.D0)
8455C
8456C input cross section high mass diffraction particle 2
8457C first possibility
8458 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8459 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8460 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8461 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8462 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8463 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8464 BP1 = 2.D0*BPOM1*SCALB1
8465 BP2 = 2.D0*BPOM2*SCALB2
8466C input cross section high mass diffraction
8467 CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8468 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8469 SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8470 BTR2(1) = DCMPLX(BTR,0.D0)
8471C second possibility: high-low mass double diffraction
8472 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8473 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8474 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8475 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8476 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8477 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8478 BP1 = 2.D0*BPOM1*SCALB1
8479 BP2 = 2.D0*BPOM2*SCALB2
8480C input cross section high mass diffraction
8481 CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8482 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8483 SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8484 BTR2(2) = DCMPLX(BTR,0.D0)
8485C
8486C input cross section for loop-pomeron
8487C first possibility
8488 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8489 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8490 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8491 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8492 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8493 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8494 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8495 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8496 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8497 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8498 BP1 = BPOM1*SCALB1
8499 BP2 = BPOM2*SCALB2
8500 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8501 & SIGTX,BTX)
8502 SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8503 BDP(1) = DCMPLX(BTX,0.D0)
8504C second possibility
8505 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8506 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8507 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8508 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8509 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8510 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8511 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8512 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8513 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8514 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8515 BP1 = BPOM1*SCALB1
8516 BP2 = BPOM2*SCALB2
8517 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8518 & SIGTX,BTX)
8519 SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8520 BDP(2) = DCMPLX(BTX,0.D0)
8521C third possibility
8522 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8523 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8524 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8525 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8526 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8527 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8528 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8529 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8530 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8531 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8532 BP1 = BPOM1*SCALB1
8533 BP2 = BPOM2*SCALB2
8534 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8535 & SIGTX,BTX)
8536 SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8537 BDP(3) = DCMPLX(BTX,0.D0)
8538C fourth possibility
8539 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8540 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8541 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8542 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8543 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8544 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8545 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8546 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8547 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8548 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8549 BP1 = BPOM1*SCALB1
8550 BP2 = BPOM2*SCALB2
8551 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8552 & SIGTX,BTX)
8553 SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8554 BDP(4) = DCMPLX(BTX,0.D0)
8555C
8556C input cross section for YY-iterated triple-pomeron
8557C .....
8558C
8559C write out input cross sections
8560 IF(IDEB(48).GE.5) THEN
8561 WRITE(LO,'(2(/1X,A))')
8562 & 'Born graph input cross sections and slopes',
8563 & '------------------------------------------'
8564 WRITE(LO,'(1X,A,3E12.3)') 'energy ',ECMP,PVIRTP
8565 WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
8566 & XM1,XM2,XM3,XM4
8567 WRITE(LO,'(A)') ' input cross sections (millibarn):'
8568 WRITE(LO,'(A,2E12.3)') ' SIGR ',SIGR
8569 WRITE(LO,'(A,2E12.3)') ' (soft) SIGP ',SIGP
8570 WRITE(LO,'(A,2E12.3)') ' (hard) SIGHR ',SIGHR
8571 WRITE(LO,'(A,2E12.3)') ' SIGHD ',SIGHD
8572 WRITE(LO,'(A,4E12.3)') ' SIGT1 ',SIGT1
8573 WRITE(LO,'(A,4E12.3)') ' SIGT2 ',SIGT2
8574 WRITE(LO,'(A,2E12.3)') ' SIGL ',SIGL
8575 WRITE(LO,'(A,4E12.3)') ' SIGDP(1-2) ',SIGDP(1),SIGDP(2)
8576 WRITE(LO,'(A,4E12.3)') ' SIGDP(3-4) ',SIGDP(3),SIGDP(4)
8577 WRITE(LO,'(A)') ' input slopes (GeV**-2)'
8578 WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
8579 WRITE(LO,'(A,2E12.3)') ' BREG1 ',BREG1
8580 WRITE(LO,'(A,2E12.3)') ' BREG2 ',BREG2
8581 WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
8582 WRITE(LO,'(A,2E12.3)') ' BPOM1 ',BPOM1
8583 WRITE(LO,'(A,2E12.3)') ' BPOM2 ',BPOM2
8584 WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
8585 WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
8586 WRITE(LO,'(A,E12.3)') ' B0PPP ',B0PPP
8587 WRITE(LO,'(A,4E12.3)') ' BTR1 ',BTR1
8588 WRITE(LO,'(A,4E12.3)') ' BTR2 ',BTR2
8589 WRITE(LO,'(A,2E12.3)') ' BLOO ',BLOO
8590 WRITE(LO,'(A,4E12.3)') ' BDP(1-2) ',BDP(1),BDP(2)
8591 WRITE(LO,'(A,4E12.3)') ' BDP(3-4) ',BDP(3),BDP(4)
8592 ENDIF
8593C
8594 BPOM = BPOM*GEV2MB
8595 BREG = BREG*GEV2MB
8596 BHAR = BHAR*GEV2MB
8597 BHAD = BHAD*GEV2MB
8598 BTR1(1) = BTR1(1)*GEV2MB
8599 BTR1(2) = BTR1(2)*GEV2MB
8600 BTR2(1) = BTR2(1)*GEV2MB
8601 BTR2(2) = BTR2(2)*GEV2MB
8602 BLOO = BLOO*GEV2MB
8603C
8604 BP4 =BPOM*4.D0
8605 BR4 =BREG*4.D0
8606 BHR4=BHAR*4.D0
8607 BHD4=BHAD*4.D0
8608 BT14(1)=BTR1(1)*4.D0
8609 BT14(2)=BTR1(2)*4.D0
8610 BT24(1)=BTR2(1)*4.D0
8611 BT24(2)=BTR2(2)*4.D0
8612 BL4 =BLOO*4.D0
8613C
8614 ZIGP = SIGP/(PI2*BP4)
8615 ZIGR = SIGR/(PI2*BR4)
8616 ZIGHR = SIGHR/(PI2*BHR4)
8617 ZIGHD = SIGHD/(PI2*BHD4)
8618 ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
8619 ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
8620 ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
8621 ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
8622 ZIGL = SIGL/(PI2*BL4)
8623 DO 20 I=1,4
8624 BDP(I) = BDP(I)*GEV2MB
8625 BD4(I) = BDP(I)*4.D0
8626 ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
8627 20 CONTINUE
8628C
8629 IF(IDEB(48).GE.10) THEN
8630 WRITE(LO,'(A)') ' normalized input values:'
8631 WRITE(LO,'(A,2E12.3)') ' ZIGR ',ZIGR
8632 WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
8633 WRITE(LO,'(A,2E12.3)') ' ZIGP ',ZIGP
8634 WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
8635 WRITE(LO,'(A,2E12.3)') ' ZIGHR ',ZIGHR
8636 WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
8637 WRITE(LO,'(A,2E12.3)') ' ZIGHD ',ZIGHD
8638 WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
8639 WRITE(LO,'(A,4E12.3)') ' ZIGT1 ',ZIGT1
8640 WRITE(LO,'(A,4E12.3)') ' ZIGT2 ',ZIGT2
8641 WRITE(LO,'(A,2E12.3)') ' ZIGL ',ZIGL
8642 WRITE(LO,'(A,4E12.3)') ' ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
8643 WRITE(LO,'(A,4E12.3)') ' ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
8644 ENDIF
8645 END
8646
8647*$ CREATE PHO_SCALES.FOR
8648*COPY PHO_SCALES
8649CDECK ID>, PHO_SCALES
8650 SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
8651C**********************************************************************
8652C
8653C calculation of scale factors
8654C (mass dependent couplings and slopes)
8655C
8656C input: XM1..XM4 external masses
8657C
8658C output: SCG1,SCG2 scales of coupling constants
8659C SCB1,SCB2 scales of coupling slope parameter
8660C
8661C*********************************************************************
8662 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8663 SAVE
8664
8665 PARAMETER ( EPS = 1.D-3 )
8666
8667C input/output channels
8668 INTEGER LI,LO
8669 COMMON /POINOU/ LI,LO
8670C event debugging information
8671 INTEGER NMAXD
8672 PARAMETER (NMAXD=100)
8673 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8674 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8675 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8676 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8677C Reggeon phenomenology parameters
8678 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8679 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8680 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8681 & ALREG,ALREGP,GR(2),B0REG(2),
8682 & GPPP,GPPR,B0PPP,B0PPR,
8683 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8684C parameters of 2x2 channel model
8685 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8686 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8687C data of c.m. system of Pomeron / Reggeon exchange
8688 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8689 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8690 & SIDP,CODP,SIFP,COFP
8691 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8692 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8693 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8694C model switches and parameters
8695 CHARACTER*8 MDLNA
8696 INTEGER ISWMDL,IPAMDL
8697 DOUBLE PRECISION PARMDL
8698 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8699
8700C scale factors for couplings
8701 ECMMIN = 2.D0
8702* ECMTP = 6.D0
8703 ECMTP = 1.D0
8704 IF(ABS(XM1-XM3).GT.EPS) THEN
8705 IF(ECMP.LT.ECMTP) THEN
8706 SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8707 ELSE
8708 SCG1 = PHISUP(1)
8709 ENDIF
8710 ELSE
8711 SCG1 = 1.D0
8712 ENDIF
8713 IF(ABS(XM2-XM4).GT.EPS) THEN
8714 IF(ECMP.LT.ECMTP) THEN
8715 SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8716 ELSE
8717 SCG2 = PHISUP(2)
8718 ENDIF
8719 ELSE
8720 SCG2 = 1.D0
8721 ENDIF
8722C
8723C scale factors for slope parameters
8724 IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
8725 SCB1 = 1.D0
8726 SCB2 = 1.D0
8727 ELSE IF(ISWMDL(1).EQ.2) THEN
8728C rational
8729 SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
8730 SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
8731 ELSE IF(ISWMDL(1).GE.3) THEN
8732C symmetric gaussian
8733 SCB1 = VAR*(XM1-XM3)**2
8734 IF(SCB1.LT.25.D0) THEN
8735 SCB1 = EXP(-SCB1)
8736 ELSE
8737 SCB1 = 0.D0
8738 ENDIF
8739 SCB2 = VAR*(XM2-XM4)**2
8740 IF(SCB2.LT.25.D0) THEN
8741 SCB2 = EXP(-SCB2)
8742 ELSE
8743 SCB2 = 0.D0
8744 ENDIF
8745 ELSE
8746 WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
8747 & ISWMDL(1)
8748 CALL PHO_ABORT
8749 ENDIF
8750C debug output
8751 IF(IDEB(65).GE.10) THEN
8752 WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
8753 & XM1,XM2,XM3,XM4
8754 WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
8755 & SCB1,SCB2,SCG1,SCG2
8756 ENDIF
8757 END
8758
8759*$ CREATE PHO_EIKON.FOR
8760*COPY PHO_EIKON
8761CDECK ID>, PHO_EIKON
8762 SUBROUTINE PHO_EIKON(IP,IFHARD,B)
8763C*********************************************************************
8764C
8765C calculation of unitarized amplitudes
8766C
8767C input: IP particle combination
8768C IFHARD -1 ignore previously calculated Born
8769C cross sections
8770C 0 calculate hard Born cross sections or
8771C take them from interpolation table
8772C (if available)
8773C 1 take hard cross sections from /POSBRN/
8774C B impact parameter (mb**(1/2))
8775C /POSBRN/ input cross sections
8776C /GLOCMS/ cm energy
8777C /POPREG/ soft and hard parameters
8778C
8779C output: /POINT4/
8780C AMPEL purely elastic amplitude
8781C AMPVM quasi-elastically vectormeson prod.
8782C AMLMSD(2) amplitudes of low mass sing. diffr.
8783C AMHMSD(2) amplitudes of high mass sing. diffr.
8784C AMLMDD amplitude of low mass double diffr.
8785C AMHMDD amplitude of high mass double diffr.
8786C
8787C*********************************************************************
8788 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8789 SAVE
8790
8791 PARAMETER(ITWO=2,
8792 & ITHREE=3,
8793 & IFOUR=4,
8794 & IFIVE=5,
8795 & ISIX=6,
8796 & FIVE=5.D0,
8797 & THOUS=1.D3,
8798 & EXPMAX=70.D0,
8799 & DEPS=1.D-20)
8800
8801C input/output channels
8802 INTEGER LI,LO
8803 COMMON /POINOU/ LI,LO
8804C event debugging information
8805 INTEGER NMAXD
8806 PARAMETER (NMAXD=100)
8807 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8808 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8809 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8810 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8811C complex Born graph amplitudes used for unitarization
8812 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
8813 & AMHMDD,AMPDP
8814 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
8815 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
8816C cross sections
8817 INTEGER IPFIL,IFAFIL,IFBFIL
8818 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
8819 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
8820 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
8821 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
8822 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
8823 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
8824 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
8825 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
8826 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
8827 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
8828 & IPFIL,IFAFIL,IFBFIL
8829C Born graph cross sections and slopes
8830 INTEGER Max_pro_3
8831 PARAMETER ( Max_pro_3 = 16 )
8832 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8833 & SIGD1,SIGD2,DSIGH
8834 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8835 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8836C scaled cross sections and slopes
8837 COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8838 & ZIGD1,ZIGD2,
8839 & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8840 COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8841 & ZIGDP(4),ZIGD1(2),ZIGD2(2),
8842 & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8843 & BD1(2),BD2(2)
8844C Born graph cross sections after applying diffraction model
8845 DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
8846 & SBOLPO,SBODPO
8847 COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
8848 & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
8849 & SBODPO(0:4,4)
8850C global event kinematics and particle IDs
8851 INTEGER IFPAP,IFPAB
8852 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
8853 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
8854C data of c.m. system of Pomeron / Reggeon exchange
8855 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8856 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8857 & SIDP,CODP,SIFP,COFP
8858 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8859 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8860 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8861C Reggeon phenomenology parameters
8862 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8863 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8864 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8865 & ALREG,ALREGP,GR(2),B0REG(2),
8866 & GPPP,GPPR,B0PPP,B0PPR,
8867 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8868C parameters of 2x2 channel model
8869 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8870 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8871C model switches and parameters
8872 CHARACTER*8 MDLNA
8873 INTEGER ISWMDL,IPAMDL
8874 DOUBLE PRECISION PARMDL
8875 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8876C unitarized amplitudes for different diffraction channels
8877 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
8878 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
8879 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
8880 & ZXL,BXL
8881 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
8882 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
8883 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
8884 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
8885 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
8886 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
8887 & ZXL(4,4),BXL(4,4)
8888
8889 COMPLEX*16 CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
8890 & AUXL,AMPR,AMPO,AMPP,AMPQ
8891
8892 DIMENSION PVOLD(2)
8893
8894 DATA ELAST / 0.D0 /
8895 DATA IPOLD / -1 /
8896 DATA PVOLD / -1.D0, -1.D0 /
8897 DATA XMPOM / 0.766D0 /
8898 DATA XMVDM / 0.766D0 /
8899
8900 DCMPLX(X,Y) = CMPLX(X,Y)
8901
8902C calculation of scaled cross sections and slopes
8903
8904C test for redundant calculation
8905 IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
8906 & .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
8907C effective particle masses, VDM assumption
8908 XMASS1 = PMASS(1)
8909 XMASS2 = PMASS(2)
8910 RMASS1 = RMASS(1)
8911 RMASS2 = RMASS(2)
8912 IF(IFPAP(1).EQ.22) THEN
8913 XMASS1 = XMVDM
8914 ELSE IF(IFPAP(1).EQ.990) THEN
8915 XMASS1 = XMPOM
8916 ENDIF
8917 IF(IFPAP(2).EQ.22) THEN
8918 XMASS2 = XMVDM
8919 ELSE IF(IFPAP(2).EQ.990) THEN
8920 XMASS2 = XMPOM
8921 ENDIF
8922C different particle combinations
8923 IF(IP.EQ.3) THEN
8924 XMASS1 = XMASS2
8925 RMASS1 = RMASS2
8926 ELSE IF(IP.EQ.4) THEN
8927 XMASS1 = XMPOM
8928 RMASS1 = XMASS1
8929 ENDIF
8930 IF(IP.GT.1) THEN
8931 XMASS2 = XMPOM
8932 RMASS2 = XMASS2
8933 ENDIF
8934C update pomeron CM system
8935 PMASSP(1) = XMASS1
8936 PMASSP(2) = XMASS2
8937 ECMP = ECM
8938
8939 CZERO = DCMPLX(0.D0,0.D0)
8940 CONE = DCMPLX(1.D0,0.D0)
8941 ELAST = ECM
8942 PVOLD(1) = PVIRT(1)
8943 PVOLD(2) = PVIRT(2)
8944 IPOLD = IP
8945
8946C purely elastic scattering
8947 CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
8948 ZXP(1,1) = ZIGP
8949 BXP(1,1) = BPOM
8950 ZXR(1,1) = ZIGR
8951 BXR(1,1) = BREG
8952 ZXH(1,1) = ZIGHR
8953 BXH(1,1) = BHAR
8954 ZXD(1,1) = ZIGHD
8955 BXD(1,1) = BHAD
8956 ZXT1A(1,1) = ZIGT1(1)
8957 BXT1A(1,1) = BTR1(1)
8958 ZXT1B(1,1) = ZIGT1(2)
8959 BXT1B(1,1) = BTR1(2)
8960 ZXT2A(1,1) = ZIGT2(1)
8961 BXT2A(1,1) = BTR2(1)
8962 ZXT2B(1,1) = ZIGT2(2)
8963 BXT2B(1,1) = BTR2(2)
8964 ZXL(1,1) = ZIGL
8965 BXL(1,1) = BLOO
8966 ZXDPE(1,1) = ZIGDP(1)
8967 BXDPE(1,1) = BDP(1)
8968 ZXDPA(1,1) = ZIGDP(2)
8969 BXDPA(1,1) = BDP(2)
8970 ZXDPB(1,1) = ZIGDP(3)
8971 BXDPB(1,1) = BDP(3)
8972 ZXDPD(1,1) = ZIGDP(4)
8973 BXDPD(1,1) = BDP(4)
8974 SBOPOM(1) = SIGP
8975 SBOREG(1) = SIGR
8976 SBOHAR(1) = SIGHR
8977 SBOHAD(1) = SIGHD
8978 SBOTR1(1,1) = SIGT1(1)
8979 SBOTR1(1,2) = SIGT1(2)
8980 SBOTR2(1,1) = SIGT2(1)
8981 SBOTR2(1,2) = SIGT2(2)
8982 SBOLPO(1) = SIGL
8983 SBODPO(1,1) = SIGDP(1)
8984 SBODPO(1,2) = SIGDP(2)
8985 SBODPO(1,3) = SIGDP(3)
8986 SBODPO(1,4) = SIGDP(4)
8987
8988C low mass single diffractive scattering 1
8989 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
8990 ZXP(1,2) = ZIGP
8991 BXP(1,2) = BPOM
8992 ZXR(1,2) = ZIGR
8993 BXR(1,2) = BREG
8994 ZXH(1,2) = ZIGHR
8995 BXH(1,2) = BHAR
8996 ZXD(1,2) = ZIGHD
8997 BXD(1,2) = BHAD
8998 ZXT1A(1,2) = ZIGT1(1)
8999 BXT1A(1,2) = BTR1(1)
9000 ZXT1B(1,2) = ZIGT1(2)
9001 BXT1B(1,2) = BTR1(2)
9002 ZXT2A(1,2) = ZIGT2(1)
9003 BXT2A(1,2) = BTR2(1)
9004 ZXT2B(1,2) = ZIGT2(2)
9005 BXT2B(1,2) = BTR2(2)
9006 ZXL(1,2) = ZIGL
9007 BXL(1,2) = BLOO
9008 ZXDPE(1,2) = ZIGDP(1)
9009 BXDPE(1,2) = BDP(1)
9010 ZXDPA(1,2) = ZIGDP(2)
9011 BXDPA(1,2) = BDP(2)
9012 ZXDPB(1,2) = ZIGDP(3)
9013 BXDPB(1,2) = BDP(3)
9014 ZXDPD(1,2) = ZIGDP(4)
9015 BXDPD(1,2) = BDP(4)
9016 SBOPOM(2) = SIGP
9017 SBOREG(2) = SIGR
9018 SBOHAR(2) = SIGHR
9019 SBOHAD(2) = 0.D0
9020 SBOTR1(2,1) = SIGT1(1)
9021 SBOTR1(2,2) = SIGT1(2)
9022 SBOTR2(2,1) = SIGT2(1)
9023 SBOTR2(2,2) = SIGT2(2)
9024 SBOLPO(2) = SIGL
9025 SBODPO(2,1) = SIGDP(1)
9026 SBODPO(2,2) = SIGDP(2)
9027 SBODPO(2,3) = SIGDP(3)
9028 SBODPO(2,4) = SIGDP(4)
9029
9030C low mass single diffractive scattering 2
9031 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
9032 ZXP(1,3) = ZIGP
9033 BXP(1,3) = BPOM
9034 ZXR(1,3) = ZIGR
9035 BXR(1,3) = BREG
9036 ZXH(1,3) = ZIGHR
9037 BXH(1,3) = BHAR
9038 ZXD(1,3) = ZIGHD
9039 BXD(1,3) = BHAD
9040 ZXT1A(1,3) = ZIGT1(1)
9041 BXT1A(1,3) = BTR1(1)
9042 ZXT1B(1,3) = ZIGT1(2)
9043 BXT1B(1,3) = BTR1(2)
9044 ZXT2A(1,3) = ZIGT2(1)
9045 BXT2A(1,3) = BTR2(1)
9046 ZXT2B(1,3) = ZIGT2(2)
9047 BXT2B(1,3) = BTR2(2)
9048 ZXL(1,3) = ZIGL
9049 BXL(1,3) = BLOO
9050 ZXDPE(1,3) = ZIGDP(1)
9051 BXDPE(1,3) = BDP(1)
9052 ZXDPA(1,3) = ZIGDP(2)
9053 BXDPA(1,3) = BDP(2)
9054 ZXDPB(1,3) = ZIGDP(3)
9055 BXDPB(1,3) = BDP(3)
9056 ZXDPD(1,3) = ZIGDP(4)
9057 BXDPD(1,3) = BDP(4)
9058 SBOPOM(3) = SIGP
9059 SBOREG(3) = SIGR
9060 SBOHAR(3) = SIGHR
9061 SBOHAD(3) = 0.D0
9062 SBOTR1(3,1) = SIGT1(1)
9063 SBOTR1(3,2) = SIGT1(2)
9064 SBOTR2(3,1) = SIGT2(1)
9065 SBOTR2(3,2) = SIGT2(2)
9066 SBOLPO(3) = SIGL
9067 SBODPO(3,1) = SIGDP(1)
9068 SBODPO(3,2) = SIGDP(2)
9069 SBODPO(3,3) = SIGDP(3)
9070 SBODPO(3,4) = SIGDP(4)
9071
9072C low mass double diffractive scattering
9073 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
9074 ZXP(1,4) = ZIGP
9075 BXP(1,4) = BPOM
9076 ZXR(1,4) = ZIGR
9077 BXR(1,4) = BREG
9078 ZXH(1,4) = ZIGHR
9079 BXH(1,4) = BHAR
9080 ZXD(1,4) = ZIGHD
9081 BXD(1,4) = BHAD
9082 ZXT1A(1,4) = ZIGT1(1)
9083 BXT1A(1,4) = BTR1(1)
9084 ZXT1B(1,4) = ZIGT1(2)
9085 BXT1B(1,4) = BTR1(2)
9086 ZXT2A(1,4) = ZIGT2(1)
9087 BXT2A(1,4) = BTR2(1)
9088 ZXT2B(1,4) = ZIGT2(2)
9089 BXT2B(1,4) = BTR2(2)
9090 ZXL(1,4) = ZIGL
9091 BXL(1,4) = BLOO
9092 ZXDPE(1,4) = ZIGDP(1)
9093 BXDPE(1,4) = BDP(1)
9094 ZXDPA(1,4) = ZIGDP(2)
9095 BXDPA(1,4) = BDP(2)
9096 ZXDPB(1,4) = ZIGDP(3)
9097 BXDPB(1,4) = BDP(3)
9098 ZXDPD(1,4) = ZIGDP(4)
9099 BXDPD(1,4) = BDP(4)
9100 SBOPOM(4) = SIGP
9101 SBOREG(4) = SIGR
9102 SBOHAR(4) = SIGHR
9103 SBOHAD(4) = 0.D0
9104 SBOTR1(4,1) = SIGT1(1)
9105 SBOTR1(4,2) = SIGT1(2)
9106 SBOTR2(4,1) = SIGT2(1)
9107 SBOTR2(4,2) = SIGT2(2)
9108 SBOLPO(4) = SIGL
9109 SBODPO(4,1) = SIGDP(1)
9110 SBODPO(4,2) = SIGDP(2)
9111 SBODPO(4,3) = SIGDP(3)
9112 SBODPO(4,4) = SIGDP(4)
9113
9114C calculate Born graph cross sections
9115 SBOPOM(0) = 0.D0
9116 SBOREG(0) = 0.D0
9117 SBOHAR(0) = 0.D0
9118 SBOHAD(0) = 0.D0
9119 SBOTR1(0,1) = 0.D0
9120 SBOTR1(0,2) = 0.D0
9121 SBOTR2(0,1) = 0.D0
9122 SBOTR2(0,2) = 0.D0
9123 SBOLPO(0) = 0.D0
9124 SBODPO(0,1) = 0.D0
9125 SBODPO(0,2) = 0.D0
9126 SBODPO(0,3) = 0.D0
9127 SBODPO(0,4) = 0.D0
9128 DO 150 I=1,4
9129 SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
9130 SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
9131 SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
9132 SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
9133 SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
9134 SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
9135 SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
9136 SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
9137 SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
9138 SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
9139 SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
9140 SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
9141 SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
9142 150 CONTINUE
9143
9144 SIGPOM = SBOPOM(0)
9145 SIGREG = SBOREG(0)
9146 SIGTR1(1) = SBOTR1(0,1)
9147 SIGTR1(2) = SBOTR1(0,2)
9148 SIGTR2(1) = SBOTR2(0,1)
9149 SIGTR2(2) = SBOTR2(0,2)
9150 SIGLOO = SBOLPO(0)
9151 SIGDPO(1) = SBODPO(0,1)
9152 SIGDPO(2) = SBODPO(0,2)
9153 SIGDPO(3) = SBODPO(0,3)
9154 SIGDPO(4) = SBODPO(0,4)
9155 SIGHAR = SBOHAR(0)
9156 SIGDIR = SBOHAD(0)
9157 ENDIF
9158
9159 B24=DCMPLX(B**2,0.D0)/4.D0
9160
9161 AMPEL = CZERO
9162 AMPR = CZERO
9163 AMPO = CZERO
9164 AMPP = CZERO
9165 AMPQ = CZERO
9166 AMLMSD(1) = CZERO
9167 AMLMSD(2) = CZERO
9168 AMHMSD(1) = CZERO
9169 AMHMSD(2) = CZERO
9170 AMLMDD = CZERO
9171 AMHMDD = CZERO
9172
9173C different models
9174
9175 IF(ISWMDL(1).LT.3) THEN
9176C pomeron
9177 AUXP = ZXP(1,1)*EXP(-B24/BXP(1,1))
9178C reggeon
9179 AUXR = ZXR(1,1)*EXP(-B24/BXR(1,1))
9180C hard resolved processes
9181 AUXH = ZXH(1,1)*EXP(-B24/BXH(1,1))
9182C hard direct processes
9183 AUXD = ZXD(1,1)*EXP(-B24/BXD(1,1))
9184C triple-Pomeron: baryon high mass diffraction
9185 AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
9186 & + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
9187C triple-Pomeron: photon/meson high mass diffraction
9188 AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
9189 & + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
9190C loop-Pomeron
9191 AUXL = ZXL(1,1)*EXP(-B24/BXL(1,1))
9192 ENDIF
9193
9194 IF(ISWMDL(1).EQ.0) THEN
9195 AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
9196 & *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
9197 & +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
9198 & )
9199 AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
9200 & +AUXT1+AUXT2+AUXL))
9201 AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
9202 & +AUXT1+AUXT2+AUXL))
9203 AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
9204 & +AUXT1+AUXT2+AUXL))
9205 AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
9206 & +AUXT1+AUXT2+AUXL))
9207
9208 ELSE IF(ISWMDL(1).EQ.1) THEN
9209 AMPR = 0.5D0*SQRT(VDMQ2F(1))*
9210 & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
9211 AMPO = 0.5D0*SQRT(VDMQ2F(2))*
9212 & ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
9213 AMPP = 0.5D0*SQRT(VDMQ2F(3))*
9214 & ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
9215 AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
9216 & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
9217 AMPEL = SQRT(VDMQ2F(1))*AMPR
9218 & + SQRT(VDMQ2F(2))*AMPO
9219 & + SQRT(VDMQ2F(3))*AMPP
9220 & + SQRT(VDMQ2F(4))*AMPQ
9221 & + AUXD/2.D0
9222
9223C simple analytic two channel model (version A)
9224 ELSE IF(ISWMDL(1).EQ.3) THEN
9225 CALL PHO_CHAN2A(B)
9226
9227 ELSE
9228 WRITE(LO,'(1X,A,I2)')
9229 & 'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
9230 STOP
9231 ENDIF
9232
9233 END
9234
9235*$ CREATE PHO_DSIGDT.FOR
9236*COPY PHO_DSIGDT
9237CDECK ID>, PHO_DSIGDT
9238 SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
9239C*********************************************************************
9240C
9241C calculation of unitarized amplitude
9242C and differential cross section
9243C
9244C input: EE cm energy (GeV)
9245C XTA(1,*) t values (GeV**2)
9246C NFILL entries in t table
9247C
9248C output: XTA(2,*) DSIG/DT g p --> g h/V (mub/GeV**2)
9249C XTA(3,*) DSIG/DT g p --> rho0 h/V
9250C XTA(4,*) DSIG/DT g p --> omega0 h/V
9251C XTA(5,*) DSIG/DT g p --> phi h/V
9252C XTA(6,*) DSIG/DT g p --> pi+ pi- h/V (continuum)
9253C
9254C*********************************************************************
9255 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9256 SAVE
9257
9258 PARAMETER(ITWO=2,
9259 & ITHREE=3,
9260 & THOUS=1.D3,
9261 & DEPS=1.D-20)
9262
9263 DIMENSION XTA(6,NFILL)
9264
9265C input/output channels
9266 INTEGER LI,LO
9267 COMMON /POINOU/ LI,LO
9268C some constants
9269 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9270 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9271 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9272C integration precision for hard cross sections (obsolete)
9273 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9274 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9275C event debugging information
9276 INTEGER NMAXD
9277 PARAMETER (NMAXD=100)
9278 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9279 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9280 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9281 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9282C global event kinematics and particle IDs
9283 INTEGER IFPAP,IFPAB
9284 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9285 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9286C complex Born graph amplitudes used for unitarization
9287 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9288 & AMHMDD,AMPDP
9289 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9290 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9291
9292 COMPLEX*16 XT,AMP,CZERO
9293 DIMENSION AMP(5),XPNT(96),WGHT(96),XT(5,100)
9294 CHARACTER*12 FNA
9295
9296 CDABS(AMPEL) = ABS(AMPEL)
9297 DCMPLX(X,Y) = CMPLX(X,Y)
9298
9299 CZERO=DCMPLX(0.D0,0.D0)
9300
9301 ETMP = ECM
9302 ECM = EE
9303
9304 IF(NFILL.GT.100) THEN
9305 WRITE(LO,'(1X,A,I4)')
9306 & 'PHO_DSIGDT:ERROR: too many entries in table',NFILL
9307 STOP
9308 ENDIF
9309C
9310 DO 100 K=1,NFILL
9311 DO 150 L=1,5
9312 XT(L,K)=CZERO
9313 150 CONTINUE
9314 100 CONTINUE
9315C
9316C impact parameter integration
9317C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9318 BMAX=10.D0
9319 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9320 IAMP = 5
9321 IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
9322 I1 = 1
9323 I2 = 0
9324 ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
9325 I1 = 0
9326 I2 = 1
9327 ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
9328 I1 = 1
9329 I2 = 1
9330 ELSE
9331 I1 = 0
9332 I2 = 0
9333 IAMP = 1
9334 ENDIF
9335 J1 = I1*2
9336 K1 = I1*3
9337 L1 = I1*4
9338 J2 = I2*2
9339 K2 = I2*3
9340 L2 = I2*4
9341C
9342 DO 200 I=1,NGAUSO
9343 WG=WGHT(I)*XPNT(I)
9344C calculate amplitudes
9345 IF(I.EQ.1) THEN
9346 CALL PHO_EIKON(1,-1,XPNT(I))
9347 ELSE
9348 CALL PHO_EIKON(1,1,XPNT(I))
9349 ENDIF
9350 AMP(1) = AMPEL
9351 AMP(2) = AMPVM(I1,I2)
9352 AMP(3) = AMPVM(J1,J2)
9353 AMP(4) = AMPVM(K1,K2)
9354 AMP(5) = AMPVM(L1,L2)
9355C
9356 DO 400 J=1,NFILL
9357 XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
9358 FAC = PHO_BESSJ0(XX)*WG
9359 DO 500 K=1,IAMP
9360 XT(1,J)=XT(1,J)+AMP(K)*FAC
9361 500 CONTINUE
9362 400 CONTINUE
9363 200 CONTINUE
9364C
9365C change units to mb/GeV**2
9366 FAC = 4.D0*PI/GEV2MB
9367 FNA = '(mb/GeV**2) '
9368 IF(I1+I2.EQ.1) THEN
9369 FAC = FAC*THOUS
9370 FNA = '(mub/GeV**2)'
9371 ELSE IF(I1+I2.EQ.2) THEN
9372 FAC = FAC*THOUS*THOUS
9373 FNA = '(nb/GeV**2) '
9374 ENDIF
9375 IF(IDEB(56).GE.5) THEN
9376 WRITE(LO,'(1X,A,A12,/1X,A)') 'table: -T (GeV**2) DSIG/DT ',
9377 & FNA,'------------------------------------------'
9378 ENDIF
9379 DO 600 J=1,NFILL
9380 DO 700 K=1,IAMP
9381 XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
9382 700 CONTINUE
9383 IF(IDEB(56).GE.5) THEN
9384 WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
9385 ENDIF
9386 600 CONTINUE
9387
9388 ECM = ETMP
9389 END
9390
9391*$ CREATE PHO_XSECT.FOR
9392*COPY PHO_XSECT
9393CDECK ID>, PHO_XSECT
9394 SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
9395C*********************************************************************
9396C
9397C calculation of physical cross sections
9398C
9399C input: IP particle combination
9400C IFHARD -1 reset Born graph cross section tables
9401C 0 calculate hard cross sections or take them
9402C from interpolation table (if available)
9403C 1 assume that hard cross sections are already
9404C calculated and stored in /POSBRN/
9405C EE cms energy (GeV)
9406C
9407C output: /POSBRN/ input cross sections
9408C /POZBRN/ scaled input cross values
9409C /POCSEC/ physical cross sections and slopes
9410C
9411C slopes in GeV**-2, cross sections in mb
9412C
9413C*********************************************************************
9414 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9415 SAVE
9416
9417 PARAMETER(ONEM=-1.D0,
9418 & THOUS=1.D3,
9419 & DEPS=1.D-20)
9420
9421C input/output channels
9422 INTEGER LI,LO
9423 COMMON /POINOU/ LI,LO
9424C some constants
9425 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9426 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9427 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9428C event debugging information
9429 INTEGER NMAXD
9430 PARAMETER (NMAXD=100)
9431 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9432 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9433 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9434 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9435C integration precision for hard cross sections (obsolete)
9436 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9437 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9438C model switches and parameters
9439 CHARACTER*8 MDLNA
9440 INTEGER ISWMDL,IPAMDL
9441 DOUBLE PRECISION PARMDL
9442 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9443C Born graph cross sections and slopes
9444 INTEGER Max_pro_3
9445 PARAMETER ( Max_pro_3 = 16 )
9446 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9447 & SIGD1,SIGD2,DSIGH
9448 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9449 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9450C cross sections
9451 INTEGER IPFIL,IFAFIL,IFBFIL
9452 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9453 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9454 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9455 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9456 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9457 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9458 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9459 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9460 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9461 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9462 & IPFIL,IFAFIL,IFBFIL
9463C global event kinematics and particle IDs
9464 INTEGER IFPAP,IFPAB
9465 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9466 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9467
9468 CHARACTER*15 PHO_PNAME
9469
9470C complex Born graph amplitudes used for unitarization
9471 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9472 & AMHMDD,AMPDP
9473 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9474 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9475
9476 DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
9477 CHARACTER*8 VMESA(0:4),VMESB(0:4)
9478 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
9479 & 'pi+pi- ' /
9480 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
9481 & 'pi+pi- ' /
9482
9483 CDABS(AMPEL) = ABS(AMPEL)
9484
9485 ETMP = ECM
9486 IF(EE.LT.0.D0) GOTO 500
9487 ECM = EE
9488
9489C impact parameter integration
9490C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9491 BMAX=10.D0
9492 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9493 SIGTOT = 0.D0
9494 SIGINE = 0.D0
9495 SIGELA = 0.D0
9496 SIGNDF = 0.D0
9497 SIGLSD(1) = 0.D0
9498 SIGLSD(2) = 0.D0
9499 SIGLDD = 0.D0
9500 SIGHSD(1) = 0.D0
9501 SIGHSD(2) = 0.D0
9502 SIGHDD = 0.D0
9503 SIGCDF(0) = 0.D0
9504 SIG1SO = 0.D0
9505 SIG1HA = 0.D0
9506 SLEL1 = 0.D0
9507 SLEL2 = 0.D0
9508 DO 50 I=1,4
9509 SIGCDF(I) = 0.D0
9510 DO 55 K=1,4
9511 SIGVM(I,K) = 0.D0
9512 SLVM1(I,K) = 0.D0
9513 SLVM2(I,K) = 0.D0
9514 55 CONTINUE
9515 50 CONTINUE
9516
9517 DO 100 I=1,NGAUSO
9518 B2 = XPNT(I)**2
9519 WG = WGHT(I)*XPNT(I)
9520 WGB = B2*WG
9521
9522C calculate impact parameter amplitude, results in /POINT4/
9523 IF(I.EQ.1) THEN
9524 CALL PHO_EIKON(IP,IFHARD,XPNT(I))
9525 ELSE
9526 CALL PHO_EIKON(IP,1,XPNT(I))
9527 ENDIF
9528
9529 SIGTOT = SIGTOT + DREAL(AMPEL)*WG
9530 SIGELA = SIGELA + CDABS(AMPEL)**2*WG
9531 SLEL1 = SLEL1 + AMPEL*WGB
9532 SLEL2 = SLEL2 + AMPEL*WG
9533
9534 DO 110 J=1,4
9535 DO 120 K=1,4
9536 SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
9537 SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
9538 SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
9539 120 CONTINUE
9540 SIGCDF(J) = SIGCDF(J) + DREAL(AMPDP(J))*WG
9541 110 CONTINUE
9542
9543 SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
9544 SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
9545 SIGLDD = SIGLDD + CDABS(AMLMDD)**2*WG
9546 SIG1SO = SIG1SO + DREAL(AMPSOF)*WG
9547 SIG1HA = SIG1HA + DREAL(AMPHAR)*WG
9548 SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
9549 SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
9550 SIGHDD = SIGHDD + DREAL(AMHMDD)*WG
9551
9552 100 CONTINUE
9553
9554 SIGDIR = DREAL(SIGHD)
9555 FAC = 4.D0*PI2
9556 SIGTOT = SIGTOT*FAC
9557 SIGELA = SIGELA*FAC
9558 FACSL = 0.5D0/GEV2MB
9559 SLOEL = SLEL1/MAX(DEPS,SLEL2)*FACSL
9560
9561 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
9562 DO 130 I=1,4
9563 DO 140 J=1,4
9564 SIGVM(I,J) = SIGVM(I,J)*FAC
9565 SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
9566 140 CONTINUE
9567 130 CONTINUE
9568 SIGVM(0,0) = 0.D0
9569 DO 150 I=1,4
9570 SIGVM(0,I) = 0.D0
9571 SIGVM(I,0) = 0.D0
9572 DO 160 J=1,4
9573 SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
9574 SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
9575 160 CONTINUE
9576 SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
9577 150 CONTINUE
9578 ENDIF
9579
9580C diffractive cross sections
9581
9582 SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
9583 SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
9584 SIGLDD = SIGLDD *FAC*PARMDL(42)
9585 SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
9586 SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
9587 SIGHDD = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
9588 & *FAC*PARMDL(42)
9589
9590C double pomeron scattering
9591
9592 SIGCDF(0) = 0.D0
9593 DO 170 I=1,4
9594 SIGCDF(I) = SIGCDF(I)*FAC
9595 SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
9596 170 CONTINUE
9597
9598 SIG1SO = SIG1SO *FAC
9599 SIG1HA = SIG1HA *FAC
9600
9601 SIGINE = SIGTOT - SIGELA
9602
9603C user-forced change of diffractive cross section
9604
9605 IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
9606
9607C use optional explicit parametrization for single-diffraction
9608
9609 SIGSD1 = SIGLSD(1)+SIGHSD(1)
9610 SIGSD2 = SIGLSD(2)+SIGHSD(2)
9611 SS = EE*EE
9612 XI_MIN = 1.5D0/SS
9613 XI_MAX = PARMDL(45)**2
9614 CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
9615 & SIG_SD1,SIG_SD2,SIG_DD)
9616 SIG_SD1 = SIG_SD1*PARMDL(40)
9617 SIG_SD2 = SIG_SD2*PARMDL(41)
9618
9619**sr
9620C DEL_SD1 = SIG_SD1-SIGSD1
9621 DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
9622**
9623
9624 FAC = SIGLSD(1)/SIGSD1
9625 SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
9626 SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
9627
9628C DEL_SD2 = SIG_SD2-SIGSD2
9629 DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
9630
9631 FAC = SIGLSD(2)/SIGSD2
9632 SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
9633 SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
9634
9635 IF(ISWMDL(30).GE.2) THEN
9636
9637C use explicit parametrization also for double diffraction diss.
9638 SIGDD = SIGLDD+SIGHDD
9639 SIG_DD = SIG_DD*PARMDL(42)
9640 DEL_DD = SIG_DD-SIGDD
9641 FAC = SIGLDD/SIGDD
9642 SIGLDD = SIGLDD+FAC*DEL_DD
9643 SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
9644 SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
9645
9646 ELSE
9647
9648C rescale double diffraction cross sections
9649 SIGLDD = SIGLDD *PARMDL(42)
9650 SIGHDD = SIGHDD *PARMDL(42)
9651 SIGCOR = DEL_SD1 + DEL_SD2
9652 & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9653
9654 ENDIF
9655
9656 ELSE
9657
9658C rescale unitarized cross sections for diffraction dissociation
9659
9660 SIGLSD(1) = SIGLSD(1)*PARMDL(40)
9661 SIGHSD(1) = SIGHSD(1)*PARMDL(40)
9662 SIGLSD(2) = SIGLSD(2)*PARMDL(41)
9663 SIGHSD(2) = SIGHSD(2)*PARMDL(41)
9664 SIGLDD = SIGLDD *PARMDL(42)
9665 SIGHDD = SIGHDD *PARMDL(42)
9666 SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
9667 & +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
9668 & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9669
9670 ENDIF
9671
9672C non-diffractive inelastic cross section
9673
9674 SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9675 & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9676 & -SIGLDD-SIGHDD
9677
9678C specify elastic scattering channel
9679
9680 500 CONTINUE
9681 IF(IFPAP(1).NE.22) THEN
9682 VMESA(1) = PHO_PNAME(IFPAB(1),0)
9683 ELSE
9684 VMESA(1) = 'rho '
9685 ENDIF
9686 IF(IFPAP(2).NE.22) THEN
9687 VMESB(1) = PHO_PNAME(IFPAB(2),0)
9688 ELSE
9689 VMESB(1) = 'rho '
9690 ENDIF
9691
9692C write out physical cross sections
9693
9694 IF(IDEB(57).GE.5) THEN
9695 WRITE(LO,'(/1X,A,I3,/1X,A)')
9696 & 'PHO_XSECT: cross sections (mb) for combination',IP,
9697 & '----------------------------------------------'
9698 WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
9699 WRITE(LO,'(5X,A,E12.3)') ' total ',SIGTOT
9700 WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGELA
9701 WRITE(LO,'(5X,A,E12.3)') ' inelastic ',SIGINE
9702 WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
9703 & SIGLSD(1)+SIGHSD(1)
9704 IF(IDEB(57).GE.7) THEN
9705 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(1)
9706 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(1)
9707 ENDIF
9708 WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
9709 & SIGLSD(2)+SIGHSD(2)
9710 IF(IDEB(57).GE.7) THEN
9711 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(2)
9712 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(2)
9713 ENDIF
9714 WRITE(LO,'(5X,A,E12.3)') ' double diff ',SIGLDD+SIGHDD
9715 IF(IDEB(57).GE.7) THEN
9716 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLDD
9717 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHDD
9718 ENDIF
9719 WRITE(LO,'(5X,A,E12.3)') ' double pomeron ',SIGCDF(0)
9720 IF(IDEB(57).GE.7) THEN
9721 WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGCDF(1)
9722 WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
9723 WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
9724 WRITE(LO,'(5X,A,E12.3)') ' excitation both ',SIGCDF(4)
9725 ENDIF
9726 WRITE(LO,'(5X,A,E12.3)') ' elastic slope ',SLOEL
9727 DO 200 I=1,4
9728 DO 210 J=1,4
9729 IF(SIGVM(I,J).GT.DEPS) THEN
9730 WRITE(LO,'(1X,3A)') 'q-elastic production of ',
9731 & VMESA(I),VMESB(J)
9732 WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
9733 IF((I.NE.0).AND.(J.NE.0))
9734 & WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
9735 ENDIF
9736 210 CONTINUE
9737 200 CONTINUE
9738 IF(IDEB(57).GE.7) THEN
9739 WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
9740 WRITE(LO,'(5X,A,E12.3)') ' one-pomeron soft ',SIG1SO
9741 WRITE(LO,'(5X,A,E12.3)') ' one-pomeron hard ',SIG1HA
9742 WRITE(LO,'(5X,A,E12.3)') ' pomeron exchange ',SIGPOM
9743 WRITE(LO,'(5X,A,E12.3)') ' reggeon exchange ',SIGREG
9744 WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
9745 WRITE(LO,'(5X,A,E12.3/)')' hard direct QCD ',
9746 & DREAL(DSIGH(15))
9747 ENDIF
9748 ENDIF
9749
9750 ECM = ETMP
9751
9752 END
9753
9754*$ CREATE PHO_IMPAMP.FOR
9755*COPY PHO_IMPAMP
9756CDECK ID>, PHO_IMPAMP
9757 SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
9758C*********************************************************************
9759C
9760C calculation of physical impact parameter amplitude
9761C
9762C input: EE cm energy (GeV)
9763C BMIN lower bound in B
9764C BMAX upper bound in B
9765C NSTEP number of values (linear)
9766C
9767C output: values written to output unit
9768C
9769C*********************************************************************
9770 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9771 SAVE
9772
9773 PARAMETER(ONEM=-1.D0,
9774 & THOUS=1.D3,
9775 & DEPS=1.D-20)
9776
9777C input/output channels
9778 INTEGER LI,LO
9779 COMMON /POINOU/ LI,LO
9780C event debugging information
9781 INTEGER NMAXD
9782 PARAMETER (NMAXD=100)
9783 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9784 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9785 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9786 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9787C model switches and parameters
9788 CHARACTER*8 MDLNA
9789 INTEGER ISWMDL,IPAMDL
9790 DOUBLE PRECISION PARMDL
9791 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9792C global event kinematics and particle IDs
9793 INTEGER IFPAP,IFPAB
9794 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9795 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9796C complex Born graph amplitudes used for unitarization
9797 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9798 & AMHMDD,AMPDP
9799 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9800 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9801
9802 ECM=EE
9803 BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
9804C
9805 WRITE(LO,'(3(/,1X,A))')
9806 & 'impact parameter amplitudes:',
9807 & ' B AMP-EL AMP-LMSD(1,2) AMP-HMSD(1,2) AMP-LMDD AMP-HMDD',
9808 & '-------------------------------------------------------------'
9809C
9810 BB = BMIN
9811 DO 100 I=1,NSTEP
9812C calculate impact parameter amplitudes
9813 IF(I.EQ.1) THEN
9814 CALL PHO_EIKON(1,-1,BMIN)
9815 ELSE
9816 CALL PHO_EIKON(1,1,BB)
9817 ENDIF
9818 WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
9819 & DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
9820 & DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
9821 BB = BB+BSTEP
9822 100 CONTINUE
9823
9824 END
9825
9826*$ CREATE PHO_PRBDIS.FOR
9827*COPY PHO_PRBDIS
9828CDECK ID>, PHO_PRBDIS
9829 SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
9830C*********************************************************************
9831C
9832C calculation of multi interactions probabilities
9833C
9834C input: IP particle combination to scatter
9835C ECM CMS energy
9836C IE index for weight storing
9837C /PROBAB/
9838C IMAX max. number of soft pomeron interactions
9839C KMAX max. number of hard pomeron interactions
9840C
9841C output: /PROBAB/
9842C PROB field of probabilities
9843C
9844C*********************************************************************
9845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9846 SAVE
9847
9848 PARAMETER ( EPS=1.D-10 )
9849
9850C input/output channels
9851 INTEGER LI,LO
9852 COMMON /POINOU/ LI,LO
9853C event debugging information
9854 INTEGER NMAXD
9855 PARAMETER (NMAXD=100)
9856 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9857 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9858 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9859 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9860C Reggeon phenomenology parameters
9861 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
9862 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
9863 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
9864 & ALREG,ALREGP,GR(2),B0REG(2),
9865 & GPPP,GPPR,B0PPP,B0PPR,
9866 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
9867C parameters of 2x2 channel model
9868 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
9869 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
9870C Born graph cross sections and slopes
9871 INTEGER Max_pro_3
9872 PARAMETER ( Max_pro_3 = 16 )
9873 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9874 & SIGD1,SIGD2,DSIGH
9875 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9876 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9877C obsolete cut-off information
9878 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
9879 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
9880C Born graph cross sections after applying diffraction model
9881 DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
9882 & SBOLPO,SBODPO
9883 COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
9884 & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
9885 & SBODPO(0:4,4)
9886C cross sections
9887 INTEGER IPFIL,IFAFIL,IFBFIL
9888 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9889 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9890 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9891 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9892 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9893 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9894 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9895 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9896 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9897 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9898 & IPFIL,IFAFIL,IFBFIL
9899C cut probability distribution
9900 INTEGER IEETA1,IIMAX,KKMAX
9901 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
9902 INTEGER IEEMAX,IMAX,KMAX
9903 REAL PROB
9904 DOUBLE PRECISION EPTAB
9905 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
9906 & IEEMAX,IMAX,KMAX
9907C energy-interpolation table
9908 INTEGER IEETA2
9909 PARAMETER ( IEETA2 = 20 )
9910 INTEGER ISIMAX
9911 DOUBLE PRECISION SIGTAB,SIGECM
9912 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
9913C average number of cut soft and hard ladders (obsolete)
9914 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
9915 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
9916C some constants
9917 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9918 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9919 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9920C integration precision for hard cross sections (obsolete)
9921 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9922 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9923C model switches and parameters
9924 CHARACTER*8 MDLNA
9925 INTEGER ISWMDL,IPAMDL
9926 DOUBLE PRECISION PARMDL
9927 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9928C unitarized amplitudes for different diffraction channels
9929 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
9930 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
9931 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
9932 & ZXL,BXL
9933 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
9934 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
9935 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
9936 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
9937 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
9938 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
9939 & ZXL(4,4),BXL(4,4)
9940
9941C local variables
9942 DIMENSION AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
9943 PARAMETER (ICHMAX=40)
9944 DIMENSION CHIFAC(4,4),AMPCOF(4)
9945 DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
9946 DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
9947
9948C combinatorical factors
9949 DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
9950 & 1.D0,-1.D0, 1.D0,-1.D0,
9951 & 1.D0,-1.D0,-1.D0, 1.D0,
9952 & 1.D0, 1.D0, 1.D0, 1.D0 /
9953
9954 DATA FACLOG / .000000000000000D+00,
9955 & .000000000000000D+00, .693147180559945D+00,
9956 & .109861228866811D+01, .138629436111989D+01,
9957 & .160943791243410D+01, .179175946922805D+01,
9958 & .194591014905531D+01, .207944154167984D+01,
9959 & .219722457733622D+01, .230258509299405D+01,
9960 & .239789527279837D+01, .248490664978800D+01,
9961 & .256494935746154D+01, .263905732961526D+01,
9962 & .270805020110221D+01, .277258872223978D+01,
9963 & .283321334405622D+01, .289037175789616D+01,
9964 & .294443897916644D+01, .299573227355399D+01,
9965 & .304452243772342D+01, .309104245335832D+01,
9966 & .313549421592915D+01, .317805383034795D+01,
9967 & .321887582486820D+01, .325809653802148D+01,
9968 & .329583686600433D+01, .333220451017520D+01,
9969 & .336729582998647D+01, .340119738166216D+01 /
9970
9971 DATA ELAST / 0.D0 /
9972 DATA IPLAST / 0 /
9973
9974C test for redundant calculation: skip cs calculation
9975 IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
9976 ELAST = ECM
9977 IPLAST = IP
9978 CALL PHO_XSECT(IP,0,ELAST)
9979 ISIMAX = IE
9980 SIGECM(IP,IE) = ECM
9981 SIGTAB(IP,1,IE) = SIGTOT
9982 SIGTAB(IP,2,IE) = SIGELA
9983 J = 2
9984 DO 5 I=0,4
9985 DO 6 K=0,4
9986 J = J+1
9987 SIGTAB(IP,J,IE) = SIGVM(I,K)
9988 6 CONTINUE
9989 5 CONTINUE
9990 SIGTAB(IP,28,IE) = SIGINE
9991 SIGTAB(IP,29,IE) = SIGDIR
9992 SIGTAB(IP,30,IE) = SIGLSD(1)
9993 SIGTAB(IP,31,IE) = SIGLSD(2)
9994 SIGTAB(IP,32,IE) = SIGHSD(1)
9995 SIGTAB(IP,33,IE) = SIGHSD(2)
9996 SIGTAB(IP,34,IE) = SIGLDD
9997 SIGTAB(IP,35,IE) = SIGHDD
9998 SIGTAB(IP,36,IE) = SIGCDF(0)
9999 SIGTAB(IP,37,IE) = SIG1SO
10000 SIGTAB(IP,38,IE) = SIG1HA
10001 SIGTAB(IP,39,IE) = SLOEL
10002 J = 39
10003 DO 7 I=1,4
10004 DO 8 K=1,4
10005 J = J+1
10006 SIGTAB(IP,J,IE) = SLOVM(I,K)
10007 8 CONTINUE
10008 7 CONTINUE
10009 SIGTAB(IP,56,IE) = SIGPOM
10010 SIGTAB(IP,57,IE) = SIGREG
10011 SIGTAB(IP,58,IE) = SIGHAR
10012 SIGTAB(IP,59,IE) = SIGDIR
10013 SIGTAB(IP,60,IE) = SIGTR1(1)
10014 SIGTAB(IP,61,IE) = SIGTR1(2)
10015 SIGTAB(IP,62,IE) = SIGTR2(1)
10016 SIGTAB(IP,63,IE) = SIGTR2(2)
10017 SIGTAB(IP,64,IE) = SIGLOO
10018 SIGTAB(IP,65,IE) = SIGDPO(1)
10019 SIGTAB(IP,66,IE) = SIGDPO(2)
10020 SIGTAB(IP,67,IE) = SIGDPO(3)
10021 SIGTAB(IP,68,IE) = SIGDPO(4)
10022
10023C consistency check
10024 SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10025 & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
10026 & -SIGLDD-SIGHDD
10027
10028 IF(SIGNDF.LE.0.D0) THEN
10029 WRITE(LO,'(//1X,A,/)')
10030 & 'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
10031 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
10032 & 'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
10033 WRITE(LO,'(4X,A,/1P,8E10.3)')
10034 &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
10035 & SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
10036 & SIGLSD(2),SIGLDD
10037 STOP
10038 ENDIF
10039
10040 IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
10041 write(LO,*) '------------------------------------------------'
10042 write(LO,*) 'IP,ECM:',IP,ECM
10043 write(LO,*) 'SIGTOT:',SIGTOT
10044 write(LO,*) 'SIGELA:',SIGELA
10045 write(LO,*) 'SIGVM :',SIGVM(0,0)
10046 write(LO,*) 'SIGCDF:',SIGCDF(0)
10047 write(LO,*) 'SIGDIR:',SIGDIR
10048 write(LO,*) 'SIGLSD:',SIGLSD
10049 write(LO,*) 'SIGHSD:',SIGHSD
10050 write(LO,*) 'SIGLDD:',SIGLDD
10051 write(LO,*) 'SIGHDD:',SIGHDD
10052 write(LO,*) 'SIGNDF:',SIGNDF
10053
10054 write(LO,*) 'SIGPOM:',SIGPOM
10055 write(LO,*) 'SIGREG:',SIGREG
10056 write(LO,*) 'SIGHAR:',SIGHAR
10057 write(LO,*) 'SIGDIR:',SIGDIR
10058 write(LO,*) 'SIGTR1:',SIGTR1
10059 write(LO,*) 'SIGTR2:',SIGTR2
10060 write(LO,*) 'SIGLOO:',SIGLOO
10061 write(LO,*) 'SIGDPO:',SIGDPO
10062 write(LO,*) 'SIG1SO:',SIG1SO
10063 write(LO,*) 'SIG1HA:',SIG1HA
10064 ENDIF
10065
10066 SIGTAB(IP,77,IE) = PTCUT(IP)
10067 SIGTAB(IP,78,IE) = SIGNDF
10068
10069 AUXFAC = PI2/SIGNDF
10070 IF(ISWMDL(1).EQ.3) THEN
10071 DO 133 I=1,4
10072 AMPCOF(I) = 0.D0
10073 DO 135 K=1,4
10074 AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
10075 135 CONTINUE
10076 AMPCOF(I) = AMPCOF(I)*AUXFAC
10077 133 CONTINUE
10078 ENDIF
10079C
10080* BMAX=5.D0*SQRT(DBLE(BPOM))
10081 BMAX=10.D0
10082 EPTAB(IP,IE) = ECM
10083 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
10084C
10085 ENDIF
10086C
10087 DO 160 K=0,KMAX
10088 DO 170 I=0,IMAX
10089 PROB(IP,IE,I,K) = 0.D0
10090 170 CONTINUE
10091 160 CONTINUE
10092 DO 120 I=1,ICHMAX
10093 PCHAIN(1,I) = 0.D0
10094 PCHAIN(2,I) = 0.D0
10095 120 CONTINUE
10096C
10097C main cross section loop
10098C**********************************************************
10099 DO 5000 IB=1,NGAUSO
10100 B24=XPNT(IB)**2/4.D0
10101 FAC = XPNT(IB)*WGHT(IB)
10102C
10103 IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
10104C
10105C amplitude construction
10106 DO 525 I=1,4
10107 AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
10108 & +ZXR(1,I)*EXP(-B24/BXR(1,I))
10109 AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
10110 AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
10111 & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
10112 & -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
10113 & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
10114 & -ZXL(1,I)*EXP(-B24/BXL(1,I))
10115 AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
10116 & +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
10117 & +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
10118 & +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
10119 AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
10120 AB(2,I) = AB(2,I)
10121 AB(3,I) = 0.D0
10122 AB(4,I) = 0.D0
10123*
10124 525 CONTINUE
10125C
10126 DO 460 I=1,4
10127 DO 500 K=1,4
10128 ABSUM2(I,K) = 0.D0
10129 DO 550 L=1,4
10130 ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
10131 550 CONTINUE
10132 ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
10133 500 CONTINUE
10134 460 CONTINUE
10135 DO 600 I=1,4
10136 CHI2(I) = 0.D0
10137 DO 650 K=1,4
10138 CHI2(I) = CHI2(I) + ABSUM2(K,I)
10139 650 CONTINUE
10140 600 CONTINUE
10141C sums instead of products
10142 DO 660 I=1,4
10143 DO 670 KD=1,4
10144 DTMP = ABS(ABSUM2(I,KD))
10145 IF(DTMP.LT.1.D-30) THEN
10146 ABSUM2(I,KD) = -50.D0
10147 ELSE
10148 ABSUM2(I,KD) = LOG(DTMP)
10149 ENDIF
10150 670 CONTINUE
10151 660 CONTINUE
10152
10153 IF(MAX(IMAX,KMAX).GT.30) THEN
10154 WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
10155 & 'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
10156 CALL PHO_ABORT
10157 ENDIF
10158
10159 DO 700 KD=1,4
10160 DO 750 I=1,4
10161 ABSTMP(I) = ABSUM2(I,KD)
10162 750 CONTINUE
10163C recursive sum
10164 CHITMP(1) = -ABSUM2(1,KD)
10165 DO 800 I=0,IMAX
10166 CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
10167 CHITMP(2) = -ABSTMP(2)
10168 DO 810 K=0,KMAX
10169 CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
10170C calculation of elastic part
10171 DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
10172 IF(DTMP.LT.-30.D0) THEN
10173 DTMP = 0.D0
10174 ELSE
10175 DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
10176 ENDIF
10177 PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
10178 810 CONTINUE
10179 800 CONTINUE
10180 700 CONTINUE
10181 PROB(IP,IE,0,0) = 0.D0
10182C
10183C**********************************************************
10184 ELSE
10185 WRITE(LO,'(1X,A,I3)')
10186 & 'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
10187 STOP
10188 ENDIF
10189 5000 CONTINUE
10190
10191C debug output
10192 IF(IDEB(55).GE.15) THEN
10193 WRITE(LO,'(/,1X,A,I3,E11.4)')
10194 & 'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
10195 & IP,ECM
10196 DO 905 I=0,MIN(IMAX,5)
10197 DO 915 K=0,MIN(KMAX,5)
10198 IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
10199 & WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
10200 915 CONTINUE
10201 905 CONTINUE
10202 ENDIF
10203C string probability (uncorrected)
10204 IF(IDEB(55).GE.5) THEN
10205 DO 955 I=0,IMAX
10206 DO 965 K=0,KMAX
10207 INDX = 2*I+2*K
10208 IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
10209 PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
10210 ENDIF
10211 965 CONTINUE
10212 955 CONTINUE
10213 WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
10214 & 'list of selected probabilities (uncorr,ECM)',ECM
10215 WRITE(LO,'(10X,A)') 'I, 0HPOM, 1HPOM, 2HPOM'
10216 DO 183 I=0,IIMAX
10217 IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
10218 & WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
10219 & PROB(IP,IE,I,1),PROB(IP,IE,I,2)
10220 183 CONTINUE
10221 ENDIF
10222C substract high-mass single and double diffraction
10223 PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
10224 & -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
10225 PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
10226C
10227C probability check
10228 CHKSUM = 0.D0
10229 PRONEG = 0.D0
10230 AVERI = 0.D0
10231 AVERK = 0.D0
10232 AVERL = 0.D0
10233 AVERM = 0.D0
10234 AVERN = 0.D0
10235 SIGMI = 0.D0
10236 SIGMK = 0.D0
10237 SIGML = 0.D0
10238 SIGMM = 0.D0
10239 DO 1001 I=0,IMAX
10240 PSOFT(I) = 0.D0
10241 1001 CONTINUE
10242 DO 1002 K=0,KMAX
10243 PHARD(K) = 0.D0
10244 1002 CONTINUE
10245 DO 1000 K=0,KMAX
10246 DO 1010 I=0,IMAX
10247 TMP = PROB(IP,IE,I,K)
10248 IF(TMP.LT.0.D0) THEN
10249 IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
10250 WRITE(LO,'(1X,A,4I4,E14.4)')
10251 & 'PHO_PRBDIS: neg.probability:',
10252 & IP,IE,I,K,PROB(IP,IE,I,K)
10253 ENDIF
10254 PRONEG = PRONEG+TMP
10255 TMP = 0.D0
10256 ENDIF
10257 CHKSUM = CHKSUM+TMP
10258 AVERI = AVERI+DBLE(I)*TMP
10259 AVERK = AVERK+DBLE(K)*TMP
10260 SIGMI = SIGMI+DBLE(I**2)*TMP
10261 SIGMK = SIGMK+DBLE(K**2)*TMP
10262 PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
10263 PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
10264 PROB(IP,IE,I,K) = CHKSUM
10265 1010 CONTINUE
10266 1000 CONTINUE
10267C
10268 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
10269 & 'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
10270C cut probabilites output
10271 IF(IDEB(55).GE.5) THEN
10272 WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
10273 DO 185 I=1,ICHMAX
10274 IF(ABS(PCHAIN(1,I)).GT.1.D-10)
10275 & WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
10276 185 CONTINUE
10277 ENDIF
10278C rescaling necessary
10279 IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
10280 FAC = 1.D0/CHKSUM
10281 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
10282 & 'PHO_PRBDIS: rescaling of probabilities with factor',FAC
10283 DO 40 K=0,KMAX
10284 DO 50 I=0,IMAX
10285 PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
10286 50 CONTINUE
10287 40 CONTINUE
10288 AVERI = AVERI*FAC
10289 AVERK = AVERK*FAC
10290 AVERL = AVERL*FAC
10291 AVERM = AVERM*FAC
10292 SIGMI = SIGMI*FAC**2
10293 SIGMK = SIGMK*FAC**2
10294 SIGML = SIGML*FAC**2
10295 SIGMM = SIGMM*FAC**2
10296 ENDIF
10297C
10298C probability to find Reggeon/Pomeron
10299 PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
10300 AVERJ = -PROB(IP,IE,0,0)*AVERI
10301 AVERII = AVERI-AVERJ
10302C
10303 SIGTAB(IP,74,IE) = AVERII
10304 SIGTAB(IP,75,IE) = AVERK
10305 SIGTAB(IP,76,IE) = AVERJ
10306C
10307 SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
10308 SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
10309C
10310 IF(IDEB(55).GE.1) THEN
10311
10312C average interaction probabilities
10313 WRITE(LO,'(/1X,A,/1X,A)')
10314 & 'PHO_PRBDIS: expected interaction statistics',
10315 & '-------------------------------------------'
10316 WRITE(LO,'(1X,A,E12.4,2I3)')
10317 & 'energy,IP,table index:',EPTAB(IP,IE),IP,IE
10318 WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
10319 & IMAX,KMAX
10320 WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
10321 & 'averaged number of cuts per event (eff. cs):',SIGNDF,
10322 & ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
10323 & AVERII,AVERK,AVERJ,AVERL,AVERM,
10324 & AVERI+AVERK+AVERL+AVERM
10325 WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
10326 & 'standard deviation ( sqrt(sigma) ):',
10327 & ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
10328 & SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
10329 & SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
10330 WRITE(LO,'(1X,A)') 'cross section / probability soft, hard'
10331 DO I=0,MIN(IMAX,KMAX)
10332 WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
10333 & I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
10334 ENDDO
10335
10336C cross check of probability distribution and inclusive cross section
10337 PSsum_1 = 0.D0
10338 PSsum_2 = 0.D0
10339 PHsum_1 = 0.D0
10340 PHsum_2 = 0.D0
10341 do i=1,IMAX
10342 PSsum_1 = PSsum_1+PSOFT(i)*FAC
10343 PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
10344 enddo
10345 do k=1,KMAX
10346 PHsum_1 = PHsum_1+PHARD(k)
10347 PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
10348 enddo
10349 WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
10350 & PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
10351
10352 ENDIF
10353
10354 END
10355
10356*$ CREATE PHO_SAMPRO.FOR
10357*COPY PHO_SAMPRO
10358CDECK ID>, PHO_SAMPRO
10359 SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
10360C***********************************************************************
10361C
10362C routine to sample kind of process
10363C
10364C input: IP particle combination
10365C IFP1/2 PDG number of particle 1/2
10366C ECM c.m. energy (GeV)
10367C PVIR1/2 virtuality of particle 1/2 (GeV**2, positive)
10368C SPROB suppression factor for processes 1-7
10369C due to rapidity gap survival probability
10370C IPROC mode
10371C -2 output of statistics
10372C -1 initialization
10373C 0 sampling of process
10374C
10375C output: IPROC kind of interaction process:
10376C 1 non-diffractive resolved process
10377C 2 elastic scattering
10378C 3 quasi-elastic rho/omega/phi production
10379C 4 central diffraction
10380C 5 single diffraction according to IDIFF1
10381C 6 single diffraction according to IDIFF2
10382C 7 double diffraction
10383C 8 single-resolved / direct processes
10384C
10385C***********************************************************************
10386
10387 IMPLICIT NONE
10388
10389 SAVE
10390
10391 INTEGER IP,IFP1,IFP2,IPROC
10392 DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
10393
10394C input/output channels
10395 INTEGER LI,LO
10396 COMMON /POINOU/ LI,LO
10397C event debugging information
10398 INTEGER NMAXD
10399 PARAMETER (NMAXD=100)
10400 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10401 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10402 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10403 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10404C cross sections
10405 INTEGER IPFIL,IFAFIL,IFBFIL
10406 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10407 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10408 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10409 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10410 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10411 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10412 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10413 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10414 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10415 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10416 & IPFIL,IFAFIL,IFBFIL
10417C model switches and parameters
10418 CHARACTER*8 MDLNA
10419 INTEGER ISWMDL,IPAMDL
10420 DOUBLE PRECISION PARMDL
10421 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10422C general process information
10423 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10424 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10425C event weights and generated cross section
10426 INTEGER IPOWGC,ISWCUT,IVWGHT
10427 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
10428 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
10429 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
10430
10431 DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
10432 DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
10433 DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
10434
10435 INTEGER I,K,KMAX
10436 DOUBLE PRECISION DT_RNDM
10437 DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
10438
10439 IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
10440 & 'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
10441 & IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10442
10443 IF(IPROC.GE.0) THEN
10444
10445C interpolate cross sections
10446 CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
10447
10448C cross check
10449 IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
10450 WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
10451 & 'PHO_SAMPRO: inconsistent gap survival probability',
10452 & 'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
10453 & KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10454 ENDIF
10455
10456C calculate cumulative probabilities
10457 IF(ISWMDL(1).EQ.3) THEN
10458 IF(ISWMDL(2).GE.1) THEN
10459 SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
10460 SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
10461 SIGDDI = SIGLDD+SIGHDD
10462 SIGNDR = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10463 & - SIGSDI(1)-SIGSDI(2)-SIGDDI
10464 XPROB(1) = SIGNDR*SPROB*DBLE(IPRON(1,IP))
10465 XPROB(2) = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
10466 XPROB(3) = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
10467 XPROB(4) = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
10468 XPROB(5) = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
10469 XPROB(6) = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
10470 XPROB(7) = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
10471 XPROB(8) = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
10472 ELSE
10473 SIGHR = 0.D0
10474 IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
10475 SIGHD = 0.D0
10476 IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
10477 XPROB(1) = SIGHR/(SIGHR+SIGHD)
10478 XPROB(2) = XPROB(1)
10479 XPROB(3) = XPROB(1)
10480 XPROB(4) = XPROB(1)
10481 XPROB(5) = XPROB(1)
10482 XPROB(6) = XPROB(1)
10483 XPROB(7) = XPROB(1)
10484 XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
10485 ENDIF
10486
10487 IF(IDEB(11).GE.15) THEN
10488 WRITE(LO,'(1X,A,I3)')
10489 & 'PHO_SAMPRO: partial cross sections for IP',IP
10490 WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
10491 DO 240 I=2,8
10492 WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
10493 240 CONTINUE
10494 ENDIF
10495
10496 ELSE
10497 WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
10498 & ISWMDL(1)
10499 CALL PHO_ABORT
10500 ENDIF
10501
10502 IF(XPROB(8).LT.1.D-20) THEN
10503 IF(IDEB(11).GE.2)
10504 & WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
10505 & 'activated processes have vanishing cross section sum',
10506 & 'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
10507 IPROC = 0
10508 RETURN
10509 ENDIF
10510
10511C sample process
10512 XI = DT_RNDM(XI)*XPROB(8)
10513 DO 100 I=1,8
10514 IF(XI.LE.XPROB(I)) GOTO 110
10515 100 CONTINUE
10516 110 CONTINUE
10517 IPROC = MIN(I,8)
10518
10519 CALLS(IP) = CALLS(IP)+1.D0
10520 PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
10521 ECMSUM(IP) = ECMSUM(IP)+ECM
10522 IF(ISWMDL(2).GE.1) THEN
10523 SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
10524 ELSE
10525 SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
10526 ENDIF
10527
10528C debug output
10529 IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
10530 & 'PHO_SAMPRO: IP,CALL,PROC-ID',
10531 & IP,INT(CALLS(IP)+0.1D0),IPROC
10532
10533C statistics initialization
10534 ELSE IF(IPROC.EQ.-1) THEN
10535 DO 260 K=1,4
10536 DO 250 I=1,8
10537 PRO(I,K) = 0.D0
10538 250 CONTINUE
10539 CALLS(K) = 0.D0
10540 SIGSUM(K) = 0.D0
10541 ECMSUM(K) = 0.D0
10542 260 CONTINUE
10543
10544C write out statistics
10545 ELSE IF(IPROC.EQ.-2) THEN
10546 KMAX = 4
10547 IF(ISWMDL(2).EQ.0) KMAX=1
10548 DO 270 K=1,KMAX
10549 IF(CALLS(K).GT.0.5D0) THEN
10550 SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
10551 ECMSUM(K) = ECMSUM(K)/CALLS(K)
10552 IF(IDEB(11).GE.0) THEN
10553 WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
10554 & 'PHO_SAMPRO: internal process statistics ',
10555 & '(IP,<Ecm>)',K,ECMSUM(K),
10556 & '---------------------------------------'
10557 WRITE(LO,'(8X,A)')
10558 & ' process sampled cross section'
10559 IF(ISWMDL(2).GE.1) THEN
10560 WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
10561 & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10562 & ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
10563 & ' elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
10564 & 'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
10565 & ' double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
10566 & ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
10567 & ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
10568 & ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
10569 & ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
10570 ELSE
10571 WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
10572 & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10573 & ' double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
10574 & ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
10575 ENDIF
10576 ENDIF
10577 ENDIF
10578 270 CONTINUE
10579 ENDIF
10580
10581 END
10582
10583*$ CREATE PHO_SAMPRB.FOR
10584*COPY PHO_SAMPRB
10585CDECK ID>, PHO_SAMPRB
10586 SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
10587C********************************************************************
10588C
10589C routine to sample number of cut graphs of different kind
10590C
10591C input: IP scattering particle combination
10592C ECMI CMS energy
10593C IP -1 initialization
10594C -2 output of statistics
10595C others sampling of cuts
10596C
10597C output: ISAM number of soft Pomerons cut
10598C JSAM number of soft Reggeons cut
10599C KSAM number of hard Pomerons cut
10600C
10601C PHO_PRBDIS has to be called before
10602C
10603C********************************************************************
10604 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10605 SAVE
10606
10607C input/output channels
10608 INTEGER LI,LO
10609 COMMON /POINOU/ LI,LO
10610C event debugging information
10611 INTEGER NMAXD
10612 PARAMETER (NMAXD=100)
10613 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10614 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10615 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10616 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10617C model switches and parameters
10618 CHARACTER*8 MDLNA
10619 INTEGER ISWMDL,IPAMDL
10620 DOUBLE PRECISION PARMDL
10621 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10622C general process information
10623 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10624 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10625C nucleon-nucleus / nucleus-nucleus interface to DPMJET
10626 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
10627 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
10628 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
10629 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
10630C obsolete cut-off information
10631 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10632 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10633C cut probability distribution
10634 INTEGER IEETA1,IIMAX,KKMAX
10635 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
10636 INTEGER IEEMAX,IMAX,KMAX
10637 REAL PROB
10638 DOUBLE PRECISION EPTAB
10639 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
10640 & IEEMAX,IMAX,KMAX
10641C global event kinematics and particle IDs
10642 INTEGER IFPAP,IFPAB
10643 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
10644 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
10645C cross sections
10646 INTEGER IPFIL,IFAFIL,IFBFIL
10647 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10648 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10649 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10650 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10651 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10652 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10653 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10654 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10655 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10656 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10657 & IPFIL,IFAFIL,IFBFIL
10658C table of particle indices for recursive PHOJET calls
10659 INTEGER MAXIPX
10660 PARAMETER ( MAXIPX = 100 )
10661 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
10662 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
10663 & IPOIX1,IPOIX2,IPOIX3
10664
10665 DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
10666
10667C sample number of interactions
10668 IF(IP.GE.0) THEN
10669 ITER = 0
10670 ECMX = ECMI
10671 ECMC = ECMI
10672 KLIM = 1
10673 IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
10674 IF(IPAMDL(16).EQ.0) ECMC = SECM
10675 KLIM = 0
10676 ENDIF
10677
10678C sample up to kinematic limits only
10679 IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
10680 IF(IMAX1.LT.1) THEN
10681 IF(IPAMDL(2).EQ.1) THEN
10682C reggeon allowed
10683 ISAM = 0
10684 JSAM = 1
10685 KSAM = 0
10686 AVERB(3,IP) = AVERB(3,IP)+1.D0
10687 ELSE
10688C only pomeron even at very low energies
10689 ISAM = 1
10690 JSAM = 0
10691 KSAM = 0
10692 AVERB(1,IP) = AVERB(1,IP)+1.D0
10693 ENDIF
10694 AVERB(0,IP) = AVERB(0,IP)+1.D0
10695 GOTO 150
10696 ENDIF
10697C find interpolation factors
10698 IF(ECMX.LE.EPTAB(IP,1)) THEN
10699 I1 = 1
10700 I2 = 1
10701 ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
10702 DO 50 I=2,IEEMAX
10703 IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
10704 50 CONTINUE
10705 200 CONTINUE
10706 I1 = I-1
10707 I2 = I
10708 ELSE
10709 WRITE(LO,'(/1X,A,2E12.3)')
10710 & 'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
10711 CALL PHO_PREVNT(-1)
10712 I1 = IEEMAX
10713 I2 = IEEMAX
10714 ENDIF
10715 FAC2 = 0.D0
10716 IF(I1.NE.I2)
10717 & FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
10718 FAC1=1.D0-FAC2
10719C reggeon probability
10720 PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
10721C calculate soft suppression factor
10722 IF(IP.EQ.1) FSUPP = PARMDL(35)**2
10723 & /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
10724C
10725 10 CONTINUE
10726 ITER = ITER+1
10727 XI = DT_RNDM(FAC2)
10728 DO 260 KSAM=0,KMAX
10729 DO 270 ISAM=0,IMAX
10730 PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
10731 & +PROB(IP,I2,ISAM,KSAM)*FAC2
10732 IF(PRO.GT.XI) GOTO 100
10733 270 CONTINUE
10734 260 CONTINUE
10735 ISAM = MIN(IMAX,ISAM)
10736 KSAM = MIN(KMAX,KSAM)
10737
10738 100 CONTINUE
10739
10740 IF(ITER.GT.100) THEN
10741
10742 ISAM = 0
10743 JSAM = 1
10744 KSAM = 0
10745 IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
10746 & 'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
10747
10748 ELSE
10749
10750C reggeon contribution
10751 JSAM = 0
10752 IF(IPAMDL(2).EQ.1) THEN
10753 DO 90 I=1,ISAM
10754 IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
10755 90 CONTINUE
10756 ISAM = ISAM-JSAM
10757 ENDIF
10758C statistics of bare cuts
10759 IF(ITER.EQ.1) THEN
10760 AVERB(0,IP) = AVERB(0,IP)+1.D0
10761 AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
10762 AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
10763 AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
10764 ENDIF
10765C limitation given by field dimensions
10766 IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
10767
10768 IF(IP.EQ.1) THEN
10769
10770C reweight according to virtualities and PDF treatment
10771 IF(IPAMDL(115).GE.1) THEN
10772 IF(KSAM.EQ.0) THEN
10773 IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
10774 ENDIF
10775 ENDIF
10776
10777C reduce number of cuts according to photon virtualities
10778 IF(IPAMDL(114).GE.1) THEN
10779 110 CONTINUE
10780 I = ISAM+JSAM
10781 WGX = FSUPP**I
10782 IF(DT_RNDM(WGX).GT.WGX) THEN
10783 IF(ISAM+JSAM+KSAM.GT.1) THEN
10784 IF(JSAM.GT.0) THEN
10785 JSAM = JSAM-1
10786 GOTO 110
10787 ELSE IF(ISAM.GT.0) THEN
10788 ISAM = ISAM-1
10789 GOTO 110
10790 ENDIF
10791 ENDIF
10792 ENDIF
10793 ENDIF
10794
10795 ENDIF
10796
10797C phase space limitation
10798 120 CONTINUE
10799 XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
10800 & +DBLE(2*KSAM)*PTCUT(IP)
10801 PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
10802 IF(DT_RNDM(XM).GT.PACC) THEN
10803 IF(ISAM+JSAM+KSAM.GT.1) THEN
10804 IF(JSAM.GT.0) THEN
10805 JSAM = JSAM-1
10806 GOTO 120
10807 ELSE IF(ISAM.GT.0) THEN
10808 ISAM = ISAM-1
10809 GOTO 120
10810 ELSE IF(KSAM.GT.KLIM) THEN
10811 KSAM = KSAM-1
10812 GOTO 120
10813 ENDIF
10814 ENDIF
10815 ENDIF
10816
10817 ENDIF
10818
10819 ISAM = ISAM+JSAM/2
10820 JSAM = MOD(JSAM,2)
10821C collect statistics
10822 150 CONTINUE
10823 ECMS1(IP) = ECMS1(IP)+ECMX
10824 ECMS2(IP) = ECMS2(IP)+ECMC
10825
10826 AVERC(0,IP) = AVERC(0,IP)+1.D0
10827 AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
10828 AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
10829 AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
10830C
10831 IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
10832 & 'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
10833C
10834C initialize statistics
10835 ELSE IF(IP.EQ.-1) THEN
10836 DO 60 I=1,4
10837 ECMS1(I) = 0.D0
10838 ECMS2(I) = 0.D0
10839 DO 65 K=0,3
10840 AVERB(K,I) = 0.D0
10841 AVERC(K,I) = 0.D0
10842 65 CONTINUE
10843
10844 60 CONTINUE
10845 RETURN
10846C
10847C write out statistics
10848 ELSE IF(IP.EQ.-2) THEN
10849 WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
10850 & '----------------------------------'
10851 DO 70 I=1,4
10852 IF(AVERB(0,I).LT.2.D0) GOTO 75
10853 WRITE(LO,'(1X,A,I3,1P,2E13.3)')
10854 & 'statistics for IP,<Ecm_1>,<Ecm_2>',I,
10855 & ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
10856 WRITE(LO,'(5X,A)')
10857 & 'average number of s-pom,h-pom,reg cuts (bare)'
10858 WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
10859 & (AVERB(K,I)/AVERB(0,I),K=1,3)
10860 WRITE(LO,'(5X,A)')
10861 & 'average (with energy/virtuality corrections)'
10862 WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
10863 & (AVERC(K,I)/AVERC(0,I),K=1,3)
10864
10865 75 CONTINUE
10866 70 CONTINUE
10867 RETURN
10868 ENDIF
10869 END
10870
10871*$ CREATE PHO_TRIREG.FOR
10872*COPY PHO_TRIREG
10873CDECK ID>, PHO_TRIREG
10874 SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
10875 & SIGTR,BTR)
10876C**********************************************************************
10877C
10878C calculation of triple-Pomeron total cross section
10879C according to Gribov's Regge theory
10880C
10881C input: S squared cms energy
10882C GA coupling constant to diffractive line
10883C AA slope related to GA (GeV**-2)
10884C GB coupling constant to elastic line
10885C BB slope related to GB (GeV**-2)
10886C DELTA effective pomeron delta (intercept-1)
10887C ALPHAP slope of pomeron trajectory (GeV**-2)
10888C GPPP triple-Pomeron coupling
10889C BPPP slope related to B0PPP (GeV**-2)
10890C VIR2A virtuality of particle a (GeV**2)
10891C note: units of all coupling constants are mb**1/2
10892C
10893C output: SIGTR total triple-Pomeron cross section
10894C BTR effective triple-Pomeron slope
10895C (differs from diffractive slope!)
10896C
10897C uses E_i (Exponential-Integral function)
10898C
10899C**********************************************************************
10900 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10901 SAVE
10902
10903 PARAMETER (EPS =0.0001D0)
10904
10905C input/output channels
10906 INTEGER LI,LO
10907 COMMON /POINOU/ LI,LO
10908C event debugging information
10909 INTEGER NMAXD
10910 PARAMETER (NMAXD=100)
10911 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10912 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10913 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10914 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10915C some constants
10916 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10917 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10918 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10919
10920C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10921 SIGU = 2.5
10922C integration cut-off Sigma_L (min. squared mass of diff. blob)
10923 SIGL = 5.+VIR2A
10924C debug output
10925 IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10926 & 'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10927 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10928C
10929 IF(S.LT.5.D0) THEN
10930 SIGTR = 0.D0
10931 BTR = BPPP+BB
10932 RETURN
10933 ENDIF
10934C change units of ALPHAP to mb
10935 ALSCA = ALPHAP*GEV2MB
10936C
10937C cross section
10938 PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
10939 & EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
10940 PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
10941 PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
10942C
10943 SIGTR=PART1*(PART2-PART3)
10944C
10945C slope
10946 PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
10947 & (BB+BPPP+2.*ALPHAP*LOG(SIGU))
10948 PART2 = LOG(PART1)
10949 PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
10950 BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
10951 BTR = BTR-PART1
10952C
10953 IF(SIGTR.LT.EPS) SIGTR = 0.D0
10954 IF(BTR.LT.BB) BTR = BB
10955C
10956 IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10957 & 'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
10958 END
10959
10960*$ CREATE PHO_LOOREG.FOR
10961*COPY PHO_LOOREG
10962CDECK ID>, PHO_LOOREG
10963 SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
10964 & VIR2A,VIR2B,SIGLO,BLO)
10965C**********************************************************************
10966C
10967C calculation of loop-Pomeron total cross section
10968C according to Gribov's Regge theory
10969C
10970C input: S squared cms energy
10971C GA coupling constant to diffractive line
10972C AA slope related to GA (GeV**-2)
10973C GB coupling constant to elastic line
10974C BB slope related to GB (GeV**-2)
10975C DELTA effective pomeron delta (intercept-1)
10976C ALPHAP slope of pomeron trajectory (GeV**-2)
10977C GPPP triple-Pomeron coupling
10978C BPPP slope related to B0PPP (GeV**-2)
10979C VIR2A virtuality of particle a (GeV**2)
10980C VIR2B virtuality of particle b (GeV**2)
10981C note: units of all coupling constants are mb**1/2
10982C
10983C output: SIGLO total loop-Pomeron cross section
10984C BLO effective loop-Pomeron slope
10985C (differs from double diffractive slope!)
10986C
10987C uses E_i (Exponential-Integral function)
10988C
10989C**********************************************************************
10990 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10991 SAVE
10992
10993 PARAMETER (EPS =0.0001D0)
10994
10995C input/output channels
10996 INTEGER LI,LO
10997 COMMON /POINOU/ LI,LO
10998C event debugging information
10999 INTEGER NMAXD
11000 PARAMETER (NMAXD=100)
11001 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11002 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11003 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11004 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11005C some constants
11006 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11007 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11008 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11009
11010C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
11011 SIGU = 2.5
11012C integration cut-off Sigma_L (min. squared mass of diff. blob)
11013 SIGL = 5.+VIR2A+VIR2B
11014C debug output
11015 IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11016 & 'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
11017 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11018C
11019 IF(S.LT.5.D0) THEN
11020 SIGLO = 0.D0
11021 BLO = 2.D0*BPPP
11022 RETURN
11023 ENDIF
11024
11025C
11026C change units of ALPHAP to mb
11027 ALSCA = ALPHAP*GEV2MB
11028C
11029C cross section
11030 PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
11031 & EXP(-DELTA*BPPP/ALPHAP)
11032 PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
11033 PARTB=BPPP/ALPHAP+LOG(SIGU)
11034 SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
11035 & -PHO_EXPINT(PARTB*DELTA))
11036 & +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
11037 & )
11038C
11039C slope
11040 PART1 = LOG(ABS(PARTA/PARTB))
11041 & *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
11042 PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
11043 BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
11044 BLO = BLO-PART1
11045C
11046 IF(SIGLO.LT.EPS) SIGLO = 0.D0
11047 IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
11048C
11049 IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11050 & 'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
11051 END
11052
11053*$ CREATE PHO_TRXPOM.FOR
11054*COPY PHO_TRXPOM
11055CDECK ID>, PHO_TRXPOM
11056 SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
11057 & GPPP,BPPP,SIGDP,BDP)
11058C**********************************************************************
11059C
11060C calculation of total cross section of two tripe-Pomeron
11061C graphs in X configuration according to Gribov's Reggeon field
11062C theory
11063C
11064C input: S squared cms energy
11065C GA coupling constant to elastic line 1
11066C AA slope related to GA (GeV**-2)
11067C GB coupling constant to elastic line 2
11068C BB slope related to GB (GeV**-2)
11069C DELTA effective pomeron delta (intercept-1)
11070C ALPHAP slope of pomeron trajectory (GeV**-2)
11071C BPPP triple-Pomeron coupling
11072C BTR slope related to B0PPP (GeV**-2)
11073C note: units of all coupling constants are mb**1/2
11074C
11075C output: SIGDP total cross section for double-Pomeron
11076C scattering
11077C BDP effective double-Pomeron slope
11078C
11079C**********************************************************************
11080 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11081 SAVE
11082
11083 PARAMETER (EPS =0.0001D0)
11084
11085C input/output channels
11086 INTEGER LI,LO
11087 COMMON /POINOU/ LI,LO
11088C event debugging information
11089 INTEGER NMAXD
11090 PARAMETER (NMAXD=100)
11091 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11092 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11093 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11094 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11095C model switches and parameters
11096 CHARACTER*8 MDLNA
11097 INTEGER ISWMDL,IPAMDL
11098 DOUBLE PRECISION PARMDL
11099 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11100C some constants
11101 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11102 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11103 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11104
11105 DIMENSION XWGH1(96),XPOS1(96)
11106
11107C lower integration cut-off Sigma_L
11108 SIGL = PARMDL(71)**2
11109C upper integration cut-off Sigma_U
11110 C = 1.D0-1.D0/PARMDL(70)**2
11111 C = MAX(PARMDL(72),C)
11112 SIGU = (1.D0-C)**2*S
11113C integration precision
11114 NGAUS1=16
11115C
11116C debug output
11117 IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11118 & 'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
11119 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11120C
11121 IF(SIGU.LE.SIGL) THEN
11122 SIGDP = 0.D0
11123 BDP = AA+BB
11124 RETURN
11125 ENDIF
11126C
11127C cross section
11128C
11129 XIL = LOG(SIGL)
11130 XIU = LOG(SIGU)
11131 XI = LOG(S)
11132 FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
11133 ALPHA2 = 2.D0*ALPHAP
11134 ALOC = LOG(1.D0/(1.D0-C))
11135 CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
11136 XSUM = 0.D0
11137 DO 100 I1=1,NGAUS1
11138 AMXSQ = EXP(XPOS1(I1))
11139 ALOSMX = LOG(S/AMXSQ)
11140 ALCSMX = LOG((1.D0-C)*S/AMXSQ)
11141 W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
11142 W = MAX(0.D0,W)
11143 WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
11144C supercritical part
11145 WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
11146 XSUM = XSUM + W*XWGH1(I1)/WN*WSC
11147 100 CONTINUE
11148 SIGDP = XSUM*FAC
11149C
11150C slope
11151 BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
11152C
11153 IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11154 & 'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
11155 END
11156
11157*$ CREATE PHO_CHAN2A.FOR
11158*COPY PHO_CHAN2A
11159CDECK ID>, PHO_CHAN2A
11160 SUBROUTINE PHO_CHAN2A(BB)
11161C***********************************************************************
11162C
11163C simple two channel model to realize low mass diffraction
11164C (version A, iteration of triple- and loop-Pomeron)
11165C
11166C input: BB impact parameter (mb**1/2)
11167C
11168C output: /POINT4/
11169C AMPEL elastic amplitude
11170C AMPVM(4,4) q-elastic VM production
11171C AMLMSD(2) low mass single diffraction amplitude
11172C AMHMSD(2) high mass single diffraction amplitude
11173C AMLMDD low mass double diffraction amplitude
11174C AMHMDD high mass double diffraction amplitude
11175C AMPDP(4) central diffraction amplitude
11176C
11177C***********************************************************************
11178 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11179 SAVE
11180
11181 PARAMETER (DEPS = 1.D-5,
11182 & EIGHT = 8.D0)
11183
11184C input/output channels
11185 INTEGER LI,LO
11186 COMMON /POINOU/ LI,LO
11187C event debugging information
11188 INTEGER NMAXD
11189 PARAMETER (NMAXD=100)
11190 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11191 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11192 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11193 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11194C model switches and parameters
11195 CHARACTER*8 MDLNA
11196 INTEGER ISWMDL,IPAMDL
11197 DOUBLE PRECISION PARMDL
11198 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11199C some constants
11200 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11201 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11202 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11203C complex Born graph amplitudes used for unitarization
11204 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
11205 & AMHMDD,AMPDP
11206 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
11207 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
11208C unitarized amplitudes for different diffraction channels
11209 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
11210 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
11211 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
11212 & ZXL,BXL
11213 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
11214 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
11215 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
11216 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
11217 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
11218 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
11219 & ZXL(4,4),BXL(4,4)
11220C Reggeon phenomenology parameters
11221 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
11222 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
11223 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
11224 & ALREG,ALREGP,GR(2),B0REG(2),
11225 & GPPP,GPPR,B0PPP,B0PPR,
11226 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
11227C parameters of 2x2 channel model
11228 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
11229 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
11230C global event kinematics and particle IDs
11231 INTEGER IFPAP,IFPAB
11232 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11233 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11234
11235C local variables
11236 DIMENSION AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
11237 & CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
11238 & AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
11239 DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
11240
11241C combinatorical factors
11242 DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
11243 & 1.D0,-1.D0, 1.D0,-1.D0,
11244 & 1.D0,-1.D0,-1.D0, 1.D0,
11245 & 1.D0, 1.D0, 1.D0, 1.D0 /
11246 DATA EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
11247 & 1.D0,-1.D0,-1.D0, 1.D0,
11248 & -1.D0, 1.D0,-1.D0, 1.D0,
11249 & -1.D0,-1.D0, 1.D0, 1.D0 /
11250 DATA IELTAB / 1, 2, 3, 4,
11251 & 2, 1, 4, 3,
11252 & 3, 4, 1, 2,
11253 & 4, 3, 2, 1 /
11254
11255 IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
11256 & 'PHO_CHAN2A: impact parameter B',BB
11257
11258 B24 = BB**2/4.D0
11259 DO 25 I=1,4
11260 AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
11261 & +ZXR(1,I)*EXP(-B24/BXR(1,I))
11262 AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
11263 AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
11264 AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
11265 AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
11266 & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
11267 & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
11268 AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
11269 AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
11270 AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
11271 AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
11272 25 CONTINUE
11273
11274 DO 50 I=1,4
11275 ABSUM(I) = 0.D0
11276 DO 75 II=9,1,-1
11277 ABSUM(I) = ABSUM(I) + AB(II,I)
11278 75 CONTINUE
11279 50 CONTINUE
11280 IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
11281 & 'PHO_CHAN2A: ABSUM',ABSUM
11282
11283 DO 100 I=1,4
11284 CHI(I) = 0.D0
11285 CHDS(I) = 0.D0
11286 CHDH(I) = 0.D0
11287 CHDA(I) = 0.D0
11288 CHDB(I) = 0.D0
11289 CHDD(I) = 0.D0
11290 CHDPE(I) = 0.D0
11291 CHDPA(I) = 0.D0
11292 CHDPB(I) = 0.D0
11293 CHDPD(I) = 0.D0
11294 AMPELA(I,0) = 0.D0
11295 AMPELA(I,9) = 0.D0
11296 DO 200 K=1,4
11297 AMPELA(I,K) = 0.D0
11298 AMPELA(I,K+4) = 0.D0
11299 AMPVM(I,K) = 0.D0
11300 CHI(I) = CHI(I) + CHIFAC(K,I)*ABSUM(K)
11301 CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
11302 CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
11303 CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
11304 CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
11305 CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
11306 CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
11307 CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
11308 CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
11309 CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
11310 200 CONTINUE
11311 IF(CHI(I).LT.-DEPS) THEN
11312 IF(IDEB(86).GE.0) THEN
11313 WRITE(LO,'(1X,A,I3,2E12.3)')
11314 & 'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
11315 WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
11316 ENDIF
11317 ENDIF
11318 IF(ABS(CHI(I)).GT.200.D0) THEN
11319 EX1CHI(I) = 0.D0
11320 EX2CHI(I) = 0.D0
11321 ELSE
11322 TMP = EXP(-CHI(I))
11323 EX1CHI(I) = TMP
11324 EX2CHI(I) = TMP*TMP
11325 ENDIF
11326 100 CONTINUE
11327 IF(IDEB(86).GE.20) THEN
11328 WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
11329 ENDIF
11330
11331 AMPELA(1,0) = 4.D0
11332 DO 300 K=1,4
11333 DO 400 J=1,4
11334 CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
11335 AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
11336 AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
11337 AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
11338 AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
11339 AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
11340 AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
11341 AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
11342 AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
11343 AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
11344 AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
11345 400 CONTINUE
11346 300 CONTINUE
11347
11348 IF(IDEB(86).GE.25) THEN
11349 DO 305 I=1,9
11350 WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
11351 & (AMPELA(K,1),K=1,4)
11352 305 CONTINUE
11353 ENDIF
11354
11355C VDM factors --> amplitudes
11356C low mass excitations
11357 DO 500 I=1,4
11358 AMPCHA(I) = 0.D0
11359 DO 600 K=1,4
11360 AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
11361 600 CONTINUE
11362 500 CONTINUE
11363 AMPVME = AMPCHA(1)/EIGHT
11364 AMLMSD(1) = AMPCHA(2)/EIGHT
11365 AMLMSD(2) = AMPCHA(3)/EIGHT
11366 AMLMDD = AMPCHA(4)/EIGHT
11367C elastic part, high mass diffraction
11368 AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
11369 AMPSOF = 0.D0
11370 AMPHAR = 0.D0
11371 AMHMSD(1) = 0.D0
11372 AMHMSD(2) = 0.D0
11373 AMHMDD = 0.D0
11374 AMPDP(1) = 0.D0
11375 AMPDP(2) = 0.D0
11376 AMPDP(3) = 0.D0
11377 AMPDP(4) = 0.D0
11378 DO 450 I=1,4
11379 AMPEL = AMPEL + ELAFAC(I)*AMPELA(I,0)/8.D0
11380 AMPSOF = AMPSOF + ELAFAC(I)*AMPELA(I,1)
11381 AMPHAR = AMPHAR + ELAFAC(I)*AMPELA(I,2)
11382 AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
11383 AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
11384 AMHMDD = AMHMDD + ELAFAC(I)*AMPELA(I,5)
11385 AMPDP(1) = AMPDP(1) + ELAFAC(I)*AMPELA(I,6)
11386 AMPDP(2) = AMPDP(2) + ELAFAC(I)*AMPELA(I,7)
11387 AMPDP(3) = AMPDP(3) + ELAFAC(I)*AMPELA(I,8)
11388 AMPDP(4) = AMPDP(4) + ELAFAC(I)*AMPELA(I,9)
11389 450 CONTINUE
11390 AMPSOF = AMPSOF/16.D0
11391 AMPHAR = AMPHAR/16.D0
11392 AMHMSD(1) = AMHMSD(1)/16.D0
11393 AMHMSD(2) = AMHMSD(2)/16.D0
11394 AMHMDD = AMHMDD/16.D0
11395 AMPDP(1) = AMPDP(1)/16.D0
11396 AMPDP(2) = AMPDP(2)/16.D0
11397 AMPDP(3) = AMPDP(3)/16.D0
11398 AMPDP(4) = AMPDP(4)/16.D0
11399 IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
11400 IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
11401 IF(DREAL(AMHMDD).LE.0.D0) AMHMDD = 0.D0
11402 IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
11403 IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
11404 IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
11405 IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
11406
11407C vector-meson production, weight factors
11408 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
11409 IF(IFPAP(1).EQ.22) THEN
11410 IF(IFPAP(2).EQ.22) THEN
11411 DO 10 I=1,4
11412 DO 15 J=1,4
11413 AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
11414 15 CONTINUE
11415 10 CONTINUE
11416 ELSE
11417 AMPVM(1,1) = PARMDL(10)*AMPVME
11418 AMPVM(2,1) = PARMDL(11)*AMPVME
11419 AMPVM(3,1) = PARMDL(12)*AMPVME
11420 AMPVM(4,1) = PARMDL(13)*AMPVME
11421 ENDIF
11422 ELSE IF(IFPAP(2).EQ.22) THEN
11423 AMPVM(1,1) = PARMDL(10)*AMPVME
11424 AMPVM(1,2) = PARMDL(11)*AMPVME
11425 AMPVM(1,3) = PARMDL(12)*AMPVME
11426 AMPVM(1,4) = PARMDL(13)*AMPVME
11427 ENDIF
11428 ENDIF
11429C debug output
11430 IF(IDEB(86).GE.5) THEN
11431 WRITE(LO,'(/,1X,A)')
11432 & 'PHO_CHAN2A: impact parameter amplitudes'
11433 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMPEL',AMPEL
11434 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
11435 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
11436 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
11437 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
11438 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMPSOF/HAR',AMPSOF,AMPHAR
11439 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMLMSD',AMLMSD
11440 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMHMSD',AMHMSD
11441 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMLMDD',AMLMDD
11442 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMHMDD',AMHMDD
11443 WRITE(LO,'(1X,A,1P,8E10.3)') ' AMPDP(1-4)',AMPDP
11444 ENDIF
11445
11446 END
11447
11448*$ CREATE PHO_EVENT.FOR
11449*COPY PHO_EVENT
11450CDECK ID>, PHO_EVENT
11451 SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
11452C********************************************************************
11453C
11454C main subroutine to manage simulation processes
11455C
11456C input: NEV -1 initialization
11457C 1 generation of events
11458C 2 generation of events without rejection
11459C due to energy dependent cross section
11460C 3 generation of events without rejection
11461C using initialization energy
11462C -2 output of event generation statistics
11463C P1(4) momentum of particle 1 (internal TARGET)
11464C P2(4) momentum of particle 2 (internal PROJECTILE)
11465C FAC used for initialization:
11466C contains cross section the events corresponds to
11467C during generation: current cross section
11468C
11469C output: IREJ 0: event accepted
11470C 1: event rejected
11471C
11472C********************************************************************
11473 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11474 SAVE
11475
11476 PARAMETER ( TINY = 1.D-10 )
11477
11478 DIMENSION P1(4),P2(4)
11479
11480C input/output channels
11481 INTEGER LI,LO
11482 COMMON /POINOU/ LI,LO
11483C event debugging information
11484 INTEGER NMAXD
11485 PARAMETER (NMAXD=100)
11486 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11487 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11488 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11489 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11490C model switches and parameters
11491 CHARACTER*8 MDLNA
11492 INTEGER ISWMDL,IPAMDL
11493 DOUBLE PRECISION PARMDL
11494 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11495C general process information
11496 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11497 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11498C internal rejection counters
11499 INTEGER NMXJ
11500 PARAMETER (NMXJ=60)
11501 CHARACTER*10 REJTIT
11502 INTEGER IFAIL
11503 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11504C gamma-lepton or gamma-hadron vertex information
11505 INTEGER IGHEL,IDPSRC,IDBSRC
11506 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
11507 & RADSRC,AMSRC,GAMSRC
11508 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
11509 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
11510 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
11511C global event kinematics and particle IDs
11512 INTEGER IFPAP,IFPAB
11513 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11514 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11515C cross sections
11516 INTEGER IPFIL,IFAFIL,IFBFIL
11517 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11518 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11519 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11520 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11521 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11522 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11523 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11524 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11525 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11526 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11527 & IPFIL,IFAFIL,IFBFIL
11528C event weights and generated cross section
11529 INTEGER IPOWGC,ISWCUT,IVWGHT
11530 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11531 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11532 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11533C names of hard scattering processes
11534 INTEGER Max_pro_1
11535 PARAMETER ( Max_pro_1 = 16 )
11536 CHARACTER*18 PROC
11537 COMMON /POHPRO/ PROC(0:Max_pro_1)
11538C hard cross sections and MC selection weights
11539 INTEGER Max_pro_2
11540 PARAMETER ( Max_pro_2 = 16 )
11541 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
11542 & MH_acc_1,MH_acc_2
11543 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
11544 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
11545 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
11546 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
11547 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
11548 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
11549C table of particle indices for recursive PHOJET calls
11550 INTEGER MAXIPX
11551 PARAMETER ( MAXIPX = 100 )
11552 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11553 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11554 & IPOIX1,IPOIX2,IPOIX3
11555
11556 DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
11557
11558 IREJ = 0
11559
11560C initializations
11561 IF(NEV.EQ.-1) THEN
11562 WRITE(LO,'(/3(/1X,A))')
11563 & '=======================================================',
11564 & ' ------- initialization of event generation --------',
11565 & '======================================================='
11566 CALL PHO_SETMDL(0,0,-2)
11567C amplitude parameters
11568 CALL PHO_FITPAR(1)
11569
11570 CALL PHO_REJSTA(-1)
11571C initialize MC package
11572 CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
11573 CALL PHO_MCINI
11574 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11575 & 0.D0,-1)
11576 CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
11577
11578C cross section
11579 FAC = SIGGEN(4)
11580 DO 20 I=1,10
11581 IPRSAM(I) = 0
11582 IPRACC(I) = 0
11583 IENACC(I) = 0
11584 20 CONTINUE
11585 ISPS = 0
11586 ISPA = 0
11587 ISRS = 0
11588 ISRA = 0
11589 IHPS = 0
11590 IHPA = 0
11591 ISTS = 0
11592 ISTA = 0
11593 ISLS = 0
11594 ISLA = 0
11595 IDIS = 0
11596 IDIA = 0
11597 IDPS = 0
11598 IDPA = 0
11599 IDNS(1) = 0
11600 IDNS(2) = 0
11601 IDNS(3) = 0
11602 IDNS(4) = 0
11603 IDNA(1) = 0
11604 IDNA(2) = 0
11605 IDNA(3) = 0
11606 IDNA(4) = 0
11607 KACCEP = 0
11608 KEVENT = 0
11609 KEVGEN = 0
11610 ECMSUM = 0.D0
11611 ELSE IF(NEV.GT.0) THEN
11612C
11613C -------------- begin event generation ---------------
11614C
11615 IPAMDL(13) = 0
11616 IF(NEV.EQ.3) IPAMDL(13) = 1
11617 KEVENT = KEVENT+1
11618C enable debugging
11619 CALL PHO_TRACE(0,0,0)
11620 IF(IDEB(68).GE.2) THEN
11621 IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
11622 & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11623 ENDIF
11624 CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
11625C cross section calculation
11626 FAC = SIGGEN(3)
11627 IF(NEV.EQ.1) THEN
11628 IF(IVWGHT(1).EQ.1) THEN
11629 WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
11630 ELSE
11631 WG = SIGGEN(3)/SIGGEN(4)
11632 ENDIF
11633 IF(DT_RNDM(FAC).GT.WG) THEN
11634 IREJ = 1
11635 IF(IDEB(68).GE.6) THEN
11636 WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
11637 & 'PHO_EVENT: rejection due to cross section',
11638 & ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
11639 & KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
11640 CALL PHO_PREVNT(-1)
11641 ENDIF
11642 RETURN
11643 ENDIF
11644 ENDIF
11645 KEVGEN = KEVGEN+1
11646 SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
11647 HSWGHT(0) = MAX(1.D0,WG)
11648
11649 ITRY1 = 0
11650 50 CONTINUE
11651 ITRY1 = ITRY1+1
11652 IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11653
11654C sample process
11655 IPROCE = 0
11656 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11657 & 1.D0,IPROCE)
11658 IF(IPROCE.EQ.0) THEN
11659 IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
11660 & 'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
11661 IREJ = 50
11662 RETURN
11663 ENDIF
11664C sampling statistics
11665 IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
11666
11667 ITRY2 = 0
11668 60 CONTINUE
11669 ITRY2 = ITRY2+1
11670 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11671C sample number of cut graphs according to IPROCE and
11672C generate parton configurations+strings
11673 CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
11674C collect statistics
11675 ISPS = ISPS+KSPOM
11676 IHPS = IHPS+KHPOM
11677 ISRS = ISRS+KSREG
11678 ISTS = ISTS+KSTRG+KHTRG
11679 ISLS = ISLS+KSLOO+KHLOO
11680 IDIS = IDIS+MIN(KHDIR,1)
11681 IDPS = IDPS+KHDPO+KSDPO
11682 IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
11683 & IDNS(KHDIR) = IDNS(KHDIR)+1
11684C rejection?
11685 IF(IREJ.NE.0) THEN
11686 IF(IDEB(68).GE.4) THEN
11687 WRITE(LO,'(/1X,A,2I5)')
11688 & 'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
11689 CALL PHO_PREVNT(-1)
11690 ENDIF
11691 IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
11692 RETURN
11693 ENDIF
11694 IFAIL(1) = IFAIL(1)+1
11695 IF(ITRY1.GT.5) RETURN
11696 IF(IREJ.GE.5) THEN
11697 IF(ISWMDL(2).EQ.0) RETURN
11698 GOTO 50
11699 ENDIF
11700 IF(ITRY2.LT.5) GOTO 60
11701 GOTO 50
11702 ENDIF
11703C fragmentation of strings
11704
11705C FSR and string fragmentation is done separately by DPMJET routines
11706C CALL PHO_STRFRA(IREJ)
11707
11708C rejection?
11709 IF(IREJ.NE.0) THEN
11710 IFAIL(23) = IFAIL(23)+1
11711 IF(IDEB(68).GE.4) THEN
11712 WRITE(LO,'(/1X,A,2I5)')
11713 & 'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
11714 CALL PHO_PREVNT(-1)
11715 ENDIF
11716 GOTO 50
11717 ENDIF
11718C check of conservation of quantum numbers
11719 IF(IDEB(68).GE.-5) THEN
11720 CALL PHO_CHECK(-1,IREJ)
11721 IF(IREJ.NE.0) GOTO 50
11722 ENDIF
11723C event now completely processed and accepted
11724C acceptance statistics
11725 IPRACC(IPROCE) = IPRACC(IPROCE)+1
11726 ISPA = ISPA+KSPOM
11727 IHPA = IHPA+KHPOM
11728 ISRA = ISRA+KSREG
11729 ISTA = ISTA+(KSTRG+KHTRG)
11730 ISLA = ISLA+(KSLOO+KHLOO)
11731 IDIA = IDIA+MIN(KHDIR,1)
11732 IDPA = IDPA+KHDPO+KSDPO
11733 IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
11734 & IDNA(KHDIR) = IDNA(KHDIR)+1
11735 DO 55 I=1,IPOIX2
11736 IENACC(IPORES(I)) = IENACC(IPORES(I))+1
11737 55 CONTINUE
11738 KACCEP = KACCEP+1
11739
11740C debug output (partial / full event listing)
11741 if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
11742 & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11743 IF(IDEB(67).GE.10) THEN
11744 IF(IDEB(67).LE.15) THEN
11745 CALL PHO_PREVNT(-1)
11746 ELSE IF(IDEB(67).LE.20) THEN
11747 CALL PHO_PREVNT(0)
11748 ELSE IF(IDEB(67).LE.25) THEN
11749 CALL PHO_PREVNT(1)
11750 ELSE
11751 CALL PHO_PREVNT(2)
11752 ENDIF
11753 ENDIF
11754C
11755C effective weight
11756 DO 65 I=1,10
11757 IF(IPOWGC(I).GT.0) THEN
11758 HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
11759 ENDIF
11760 65 CONTINUE
11761 IF(IVWGHT(1).EQ.1) THEN
11762 WG = HSWGHT(0)
11763 IF(WG.GT.1.01D0) THEN
11764 IF(EVWGHT(1).LT.1.01D0) THEN
11765 WRITE(LO,'(1X,A,2I12,1PE12.3)')
11766 & 'PHO_EVENT: cross section weight > 1',
11767 & KEVENT,KACCEP,WG
11768 WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
11769 & SIGGEN(3),SIGGEN(4),EVWGHT(1)
11770 ENDIF
11771 EVWGHT(1) = HSWGHT(0)
11772 HSWGHT(0) = 1.D0
11773 ELSE
11774 EVWGHT(1) = 1.D0
11775 ENDIF
11776 ENDIF
11777
11778C effective cross section
11779 SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
11780 ECMSUM = ECMSUM+ECM
11781 SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
11782 ELSE IF(NEV.EQ.-2) THEN
11783
11784C ---------------- end of event generation ----------------------
11785
11786 WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
11787 & '====================================================',
11788 & ' --------- summary of event generation ----------',
11789 & '====================================================',
11790 & 'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
11791 & 'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
11792
11793C write out statistics
11794 IF(KACCEP.GT.0) THEN
11795
11796 FAC1 = SIGGEN(4)/DBLE(KEVENT)
11797 FAC2 = FAC/DBLE(KACCEP)
11798 WRITE(LO,'(/1X,A,/1X,A)')
11799 & 'PHO_EVENT: generated and accepted events',
11800 & '----------------------------------------'
11801 WRITE(LO,'(3X,A)')
11802 & 'process, sampled, accepted, cross section (internal/external)'
11803 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
11804 & IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
11805 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
11806 & IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
11807 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
11808 & IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
11809 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
11810 & IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
11811 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
11812 & IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
11813 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
11814 & IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
11815 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
11816 & IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
11817 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all ',IPRSAM(8),
11818 & IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
11819 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
11820 & DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
11821 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
11822 & DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
11823 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
11824 & DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
11825 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
11826 & DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
11827 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
11828 & DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
11829 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
11830 & DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
11831 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
11832 & DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
11833 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
11834 & DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
11835 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
11836 & DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
11837 IF(ISWMDL(14).GT.0) THEN
11838 WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
11839 & ISWMDL(14)
11840 WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
11841 WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
11842 WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
11843 WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
11844 WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
11845 ENDIF
11846 WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
11847 & SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
11848
11849 CALL PHO_REJSTA(-2)
11850 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11851 & 0.D0,-2)
11852 CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
11853C statistics of hard scattering processes
11854 WRITE(LO,'(2(/1X,A))')
11855 & 'PHO_EVENT: statistics of hard scattering processes',
11856 & '--------------------------------------------------'
11857 DO 43 K=1,4
11858 IF(MH_tried(0,K).GT.0) THEN
11859 WRITE(LO,'(/5X,A,I3)')
11860 & 'process (accepted,x-section internal/external) for IP:',K
11861 DO 47 M=0,Max_pro_2
11862 WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
11863 & MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
11864 & DBLE(MH_acc_2(M,K))*FAC2
11865 47 CONTINUE
11866 ENDIF
11867 43 CONTINUE
11868
11869 ELSE
11870 WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
11871 ENDIF
11872 WRITE(LO,'(/3(/1X,A)/)')
11873 & '======================================================',
11874 & ' ------- end of event generation summary --------',
11875 & '======================================================'
11876 ELSE
11877 WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
11878 ENDIF
11879
11880 END
11881
11882*$ CREATE PHO_PARTON.FOR
11883*COPY PHO_PARTON
11884CDECK ID>, PHO_PARTON
11885 SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
11886C********************************************************************
11887C
11888C calculation of complete parton configuration
11889C
11890C input: IPROC process ID 1 nondiffractive
11891C 2 elastic
11892C 3 quasi-ela. rho,omega,phi prod.
11893C 4 double Pomeron
11894C 5 single diff 1
11895C 6 single diff 2
11896C 7 double diff diss.
11897C 8 single-resolved / direct photon
11898C JM1,2 index of mother particles in /POEVT1/
11899C
11900C
11901C output: complete parton configuration in /POEVT1/
11902C IREJ 1 failure
11903C 0 success
11904C 50 rejection due to user cutoffs
11905C
11906C********************************************************************
11907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11908 SAVE
11909
11910 DIMENSION P1(4),P2(4)
11911
11912 PARAMETER ( TINY = 1.D-10 )
11913
11914C input/output channels
11915 INTEGER LI,LO
11916 COMMON /POINOU/ LI,LO
11917C event debugging information
11918 INTEGER NMAXD
11919 PARAMETER (NMAXD=100)
11920 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11921 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11922 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11923 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11924C model switches and parameters
11925 CHARACTER*8 MDLNA
11926 INTEGER ISWMDL,IPAMDL
11927 DOUBLE PRECISION PARMDL
11928 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11929C table of particle indices for recursive PHOJET calls
11930 INTEGER MAXIPX
11931 PARAMETER ( MAXIPX = 100 )
11932 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11933 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11934 & IPOIX1,IPOIX2,IPOIX3
11935C general process information
11936 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11937 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11938C global event kinematics and particle IDs
11939 INTEGER IFPAP,IFPAB
11940 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11941 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11942C cross sections
11943 INTEGER IPFIL,IFAFIL,IFBFIL
11944 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11945 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11946 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11947 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11948 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11949 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11950 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11951 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11952 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11953 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11954 & IPFIL,IFAFIL,IFBFIL
11955C event weights and generated cross section
11956 INTEGER IPOWGC,ISWCUT,IVWGHT
11957 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11958 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11959 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11960C internal rejection counters
11961 INTEGER NMXJ
11962 PARAMETER (NMXJ=60)
11963 CHARACTER*10 REJTIT
11964 INTEGER IFAIL
11965 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11966
11967 IREJ = 0
11968C clear event statistics
11969 KSPOM = 0
11970 KHPOM = 0
11971 KSREG = 0
11972 KHDIR = 0
11973 KSTRG = 0
11974 KHTRG = 0
11975 KSLOO = 0
11976 KHLOO = 0
11977 KHARD = 0
11978 KSOFT = 0
11979 KSDPO = 0
11980 KHDPO = 0
11981
11982C-------------------------------------------------------------------
11983C nondiffractive resolved processes
11984
11985 IF(IPROC.EQ.1) THEN
11986C sample number of interactions
11987 555 CONTINUE
11988 IINT = 0
11989 IP = 1
11990C generate only hard events
11991 IF(ISWMDL(2).EQ.0) THEN
11992 MHPOM = 1
11993 MSPOM = 0
11994 MSREG = 0
11995 MHDIR = 0
11996 HSWGHT(1) = 1.D0
11997 ELSE
11998C minimum bias events
11999 IPOWGC(1) = 0
12000 10 CONTINUE
12001 CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
12002 IPOWGC(1) = IPOWGC(1)+1
12003 MINT = 0
12004 MHDIR = 0
12005 MSTRG = 0
12006 MSLOO = 0
12007C
12008C resolved soft processes: pomeron and reggeon
12009 MSPOM = IINT
12010 MSREG = JINT
12011C resolved hard process: hard pomeron
12012 MHPOM = KINT
12013C resolved absorptive corrections
12014 MPTRI = 0
12015 MPLOO = 0
12016C restrictions given by user
12017 IF(MSPOM.LT.ISWCUT(1)) GOTO 10
12018 IF(MSREG.LT.ISWCUT(2)) GOTO 10
12019 IF(MHPOM.LT.ISWCUT(3)) GOTO 10
12020 HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
12021C ----------------------------
12022 IF(ISWMDL(15).EQ.0) THEN
12023 MHPOM = 0
12024 IF(MSREG.GT.0) THEN
12025 MSPOM = 0
12026 MSREG = 1
12027 ELSE
12028 MSPOM = 1
12029 MSREG = 0
12030 ENDIF
12031 ELSE IF(ISWMDL(15).EQ.1) THEN
12032 IF(MHPOM.GT.0) THEN
12033 MHPOM = 1
12034 MSPOM = 0
12035 MSREG = 0
12036 ELSE IF(MSPOM.GT.0) THEN
12037 MSPOM = 1
12038 MSREG = 0
12039 ELSE
12040 MSREG = 1
12041 ENDIF
12042 ELSE IF(ISWMDL(15).EQ.2) THEN
12043 MHPOM = MIN(1,MHPOM)
12044 ELSE IF(ISWMDL(15).EQ.3) THEN
12045 MSPOM = MIN(1,MSPOM)
12046 ENDIF
12047 ENDIF
12048C ----------------------------
12049
12050C statistics
12051 ISPS = ISPS+MSPOM
12052 IHPS = IHPS+MHPOM
12053 ISRS = ISRS+MSREG
12054 ISTS = ISTS+MSTRG
12055 ISLS = ISLS+MSLOO
12056
12057 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
12058 & 'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
12059 & KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
12060
12061 ITRY2 = 0
12062 50 CONTINUE
12063 ITRY2 = ITRY2+1
12064 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12065 KSPOM = MSPOM
12066 KSREG = MSREG
12067 KHPOM = MHPOM
12068 KHDIR = MHDIR
12069 KSTRG = MPTRI
12070 KSLOO = MPLOO
12071
12072 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12073 IF(IREJ.NE.0) THEN
12074 IF(IREJ.EQ.50) RETURN
12075 IF(IDEB(3).GE.2) THEN
12076 WRITE(LO,'(/1X,A,I5)')
12077 & 'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
12078 CALL PHO_PREVNT(-1)
12079 ENDIF
12080 RETURN
12081 ENDIF
12082 IF(MHPOM.GT.0) THEN
12083 IDNODF = 3
12084 ELSE IF(MSPOM.GT.0) THEN
12085 IDNODF = 2
12086 ELSE
12087 IDNODF = 1
12088 ENDIF
12089C check of quantum numbers of parton configurations
12090 IF(IDEB(3).GE.0) THEN
12091 CALL PHO_CHECK(1,IREJ)
12092 IF(IREJ.NE.0) GOTO 50
12093 ENDIF
12094C sample strings to prepare fragmentation
12095 CALL PHO_STRING(1,IREJ)
12096 IF(IREJ.NE.0) THEN
12097 IF(IREJ.EQ.50) RETURN
12098 IFAIL(30) = IFAIL(30)+1
12099 IF(IDEB(3).GE.2) THEN
12100 WRITE(LO,'(/1X,A,I5)')
12101 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12102 CALL PHO_PREVNT(-1)
12103 ENDIF
12104 IF(ITRY2.LT.20) GOTO 50
12105 IF(IDEB(3).GE.1) THEN
12106 WRITE(LO,'(/1X,A,I5)')
12107 & 'PHO_PARTON: rejection',ITRY2
12108 CALL PHO_PREVNT(-1)
12109 ENDIF
12110 RETURN
12111 ENDIF
12112
12113C statistics
12114 ISPA = ISPA+KSPOM
12115 IHPA = IHPA+KHPOM
12116 ISRA = ISRA+KSREG
12117 ISTA = ISTA+KSTRG
12118 ISLA = ISLA+KSLOO
12119
12120C-------------------------------------------------------------------
12121C elastic scattering / quasi-elastic rho/omega/phi production
12122
12123 ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12124 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12125 & 'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12126
12127C DPMJET call with special projectile / target: transform into CMS
12128 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12129 & CALL PHO_DFWRAP(1,JM1,JM2)
12130
12131 CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12132
12133 IF(IREJ.NE.0) THEN
12134C DPMJET call with special projectile / target: clean up
12135 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12136 & CALL PHO_DFWRAP(-2,JM1,JM2)
12137 IF(IDEB(3).GE.2) THEN
12138 WRITE(LO,'(/1X,A,I5)')
12139 & 'PHO_PARTON: rejection by PHO_QELAST',IREJ
12140 CALL PHO_PREVNT(-1)
12141 ENDIF
12142 RETURN
12143 ENDIF
12144
12145C DPMJET call with special projectile / target: transform back
12146 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12147 & CALL PHO_DFWRAP(2,JM1,JM2)
12148
12149C prepare possible decays
12150 CALL PHO_STRING(1,IREJ)
12151 IF(IREJ.NE.0) THEN
12152 IF(IREJ.EQ.50) RETURN
12153 IFAIL(30) = IFAIL(30)+1
12154 RETURN
12155 ENDIF
12156
12157C---------------------------------------------------------------------
12158C double Pomeron scattering
12159
12160 ELSE IF(IPROC.EQ.4) THEN
12161 MSOFT = 0
12162 MHARD = 0
12163 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12164 & 'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12165 IDPS = IDPS+1
12166 ITRY2 = 0
12167 60 CONTINUE
12168 ITRY2 = ITRY2+1
12169 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12170C
12171 CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12172 IF(IREJ.NE.0) THEN
12173 IF(IDEB(3).GE.2) THEN
12174 WRITE(LO,'(/1X,A,I5)')
12175 & 'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12176 CALL PHO_PREVNT(-1)
12177 ENDIF
12178 RETURN
12179 ENDIF
12180C check of quantum numbers of parton configurations
12181 IF(IDEB(3).GE.0) THEN
12182 CALL PHO_CHECK(1,IREJ)
12183 IF(IREJ.NE.0) GOTO 60
12184 ENDIF
12185C sample strings to prepare fragmentation
12186 CALL PHO_STRING(1,IREJ)
12187 IF(IREJ.NE.0) THEN
12188 IF(IREJ.EQ.50) RETURN
12189 IFAIL(30) = IFAIL(30)+1
12190 IF(IDEB(3).GE.2) THEN
12191 WRITE(LO,'(/1X,A,I5)')
12192 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12193 CALL PHO_PREVNT(-1)
12194 ENDIF
12195 IF(ITRY2.LT.10) GOTO 60
12196 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12197 CALL PHO_PREVNT(-1)
12198 RETURN
12199 ENDIF
12200 IDPA = IDPA+1
12201
12202C-----------------------------------------------------------------------
12203C single / double diffraction dissociation
12204
12205 ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12206 MSOFT = 0
12207 MHARD = 0
12208 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12209 & 'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12210 IF(IPROC.EQ.5) ID1S = ID1S+1
12211 IF(IPROC.EQ.6) ID2S = ID2S+1
12212 IF(IPROC.EQ.7) ID3S = ID3S+1
12213 ITRY2 = 0
12214 70 CONTINUE
12215 ITRY2 = ITRY2+1
12216 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12217 IPAR1 = 1
12218 IPAR2 = 1
12219 IF(IPROC.EQ.5) IPAR2 = 0
12220 IF(IPROC.EQ.6) IPAR1 = 0
12221C calculate rapidity gap survival probability
12222 SPROB = 1.D0
12223 IF(ECM.GT.10.D0) THEN
12224 IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12225 IF(SIGTR1(1).LT.1.D-10) THEN
12226 SPROB = 1.D0
12227 ELSE
12228 SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12229 ENDIF
12230 ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12231 IF(SIGTR2(1).LT.1.D-10) THEN
12232 SPROB = 1.D0
12233 ELSE
12234 SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12235 ENDIF
12236 ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12237 IF(SIGLOO.LT.1.D-10) THEN
12238 SPROB = 1.D0
12239 ELSE
12240 SPROB = SIGHDD/SIGLOO
12241 ENDIF
12242 ENDIF
12243 ENDIF
12244
12245**sr
12246* temporary patch, r.e. 8.6.99
12247 SPROB = 1.D0
12248**
12249
12250C DPMJET call with special projectile / target: transform into CMS
12251 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12252 & CALL PHO_DFWRAP(1,JM1,JM2)
12253
12254 CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12255
12256 IF(IREJ.NE.0) THEN
12257C DPMJET call with special projectile / target: clean up
12258 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12259 & CALL PHO_DFWRAP(-2,JM1,JM2)
12260 IF(IDEB(3).GE.2) THEN
12261 WRITE(LO,'(/1X,A,I5)')
12262 & 'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12263 CALL PHO_PREVNT(-1)
12264 ENDIF
12265 RETURN
12266 ENDIF
12267
12268C DPMJET call with special projectile / target: transform back
12269 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12270 & CALL PHO_DFWRAP(2,JM1,JM2)
12271
12272C check of quantum numbers of parton configurations
12273 IF(IDEB(3).GE.0) THEN
12274 CALL PHO_CHECK(1,IREJ)
12275 IF(IREJ.NE.0) GOTO 70
12276 ENDIF
12277C sample strings to prepare fragmentation
12278 CALL PHO_STRING(1,IREJ)
12279 IF(IREJ.NE.0) THEN
12280 IF(IREJ.EQ.50) RETURN
12281 IFAIL(30) = IFAIL(30)+1
12282 IF(IDEB(3).GE.2) THEN
12283 WRITE(LO,'(/1X,A,I5)')
12284 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12285 CALL PHO_PREVNT(-1)
12286 ENDIF
12287 IF(ITRY2.LT.10) GOTO 70
12288 WRITE(LO,'(/1X,A,I5)')
12289 & 'PHO_PARTON: rejection',ITRY2
12290 CALL PHO_PREVNT(-1)
12291 RETURN
12292 ENDIF
12293 IF(IPROC.EQ.5) ID1A = ID1A+1
12294 IF(IPROC.EQ.6) ID2A = ID2A+1
12295 IF(IPROC.EQ.7) ID3A = ID3A+1
12296
12297C-----------------------------------------------------------------------
12298C single / double direct processes
12299
12300 ELSE IF(IPROC.EQ.8) THEN
12301 MSREG = 0
12302 MSPOM = 0
12303 MHPOM = 0
12304 MHDIR = 1
12305 IF(IDEB(3).GE.5) THEN
12306 WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12307 ENDIF
12308 IDIS = IDIS+MHDIR
12309 ITRY2 = 0
12310 80 CONTINUE
12311 ITRY2 = ITRY2+1
12312 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12313 KSPOM = MSPOM
12314 KSREG = MSREG
12315 KHPOM = MHPOM
12316 KHDIR = 4
12317
12318 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12319 IF(IREJ.NE.0) THEN
12320 IF(IREJ.EQ.50) RETURN
12321 IF(IDEB(3).GE.2) THEN
12322 WRITE(LO,'(/1X,A,I5)')
12323 & 'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12324 CALL PHO_PREVNT(-1)
12325 ENDIF
12326 RETURN
12327 ENDIF
12328 IDNODF = 4
12329C check of quantum numbers of parton configurations
12330 IF(IDEB(3).GE.0) THEN
12331 CALL PHO_CHECK(1,IREJ)
12332 IF(IREJ.NE.0) GOTO 80
12333 ENDIF
12334C sample strings to prepare fragmentation
12335 CALL PHO_STRING(1,IREJ)
12336 IF(IREJ.NE.0) THEN
12337 IF(IREJ.EQ.50) RETURN
12338 IFAIL(30) = IFAIL(30)+1
12339 IF(IDEB(3).GE.2) THEN
12340 WRITE(LO,'(/1X,A,I5)')
12341 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12342 CALL PHO_PREVNT(-1)
12343 ENDIF
12344 IF(ITRY2.LT.10) GOTO 80
12345 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12346 CALL PHO_PREVNT(-1)
12347 RETURN
12348 ENDIF
12349 IF(IPROC.EQ.5) ID1A = ID1A+1
12350 IF(IPROC.EQ.6) ID2A = ID2A+1
12351 IF(IPROC.EQ.7) ID3A = ID3A+1
12352 IDIA = IDIA+MHDIR
12353
12354C-----------------------------------------------------------------------
12355C initialize control statistics
12356
12357 ELSE IF(IPROC.EQ.-1) THEN
12358 CALL PHO_SAMPRB(ECM,-1,0,0,0)
12359 CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12360 CALL PHO_SEAFLA(-1,0,0,DUM)
12361 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12362 & CALL PHO_QELAST(-1,1,2,0)
12363 ISPS = 0
12364 ISPA = 0
12365 ISRS = 0
12366 ISRA = 0
12367 IHPS = 0
12368 IHPA = 0
12369 ISTS = 0
12370 ISTA = 0
12371 ISLS = 0
12372 ISLA = 0
12373 ID1S = 0
12374 ID1A = 0
12375 ID2S = 0
12376 ID2A = 0
12377 ID3S = 0
12378 ID3A = 0
12379 IDPS = 0
12380 IDPA = 0
12381 IDIS = 0
12382 IDIA = 0
12383 CALL PHO_STRING(-1,IREJ)
12384 CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12385 RETURN
12386
12387C-----------------------------------------------------------------------
12388C produce statistics summary
12389
12390 ELSE IF(IPROC.EQ.-2) THEN
12391 IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12392 IF(IDEB(3).GE.0) THEN
12393 WRITE(LO,'(/1X,A,/1X,A)')
12394 & 'PHO_PARTON: internal statistics on parton configurations',
12395 & '--------------------------------------------------------'
12396 WRITE(LO,'(5X,A)') 'process sampled accepted'
12397 WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12398 WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12399 WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12400 WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12401 WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12402 WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12403 WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12404 WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12405 WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12406 WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12407 ENDIF
12408 CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12409 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12410 & CALL PHO_QELAST(-2,1,2,0)
12411 CALL PHO_STRING(-2,IREJ)
12412 CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12413 CALL PHO_SEAFLA(-2,0,0,DUM)
12414 RETURN
12415 ELSE
12416 WRITE(LO,'(1X,A,I2)')
12417 & 'PARTON:ERROR: unknown process ID ',IPROC
12418 STOP
12419 ENDIF
12420
12421 END
12422
12423*$ CREATE PHO_MCINI.FOR
12424*COPY PHO_MCINI
12425CDECK ID>, PHO_MCINI
12426 SUBROUTINE PHO_MCINI
12427C********************************************************************
12428C
12429C initialization of MC event generation
12430C
12431C********************************************************************
12432 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12433 SAVE
12434
12435 PARAMETER ( PIMASS = 0.13D0,
12436 & TINY = 1.D-10 )
12437
12438C input/output channels
12439 INTEGER LI,LO
12440 COMMON /POINOU/ LI,LO
12441C event debugging information
12442 INTEGER NMAXD
12443 PARAMETER (NMAXD=100)
12444 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12445 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12446 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12447 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12448C model switches and parameters
12449 CHARACTER*8 MDLNA
12450 INTEGER ISWMDL,IPAMDL
12451 DOUBLE PRECISION PARMDL
12452 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12453C general process information
12454 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12455 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12456C cross sections
12457 INTEGER IPFIL,IFAFIL,IFBFIL
12458 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12459 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12460 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12461 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12462 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12463 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12464 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12465 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12466 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12467 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12468 & IPFIL,IFAFIL,IFBFIL
12469C hard cross sections and MC selection weights
12470 INTEGER Max_pro_2
12471 PARAMETER ( Max_pro_2 = 16 )
12472 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12473 & MH_acc_1,MH_acc_2
12474 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12475 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12476 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12477 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12478 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12479 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12480C interpolation tables for hard cross section and MC selection weights
12481 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12482 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12483 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12484 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12485 & HQ2a_tab,HQ2b_tab,HEcm_tab
12486 COMMON /POHTAB/
12487 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12488 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12489 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12490 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12491 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12492 & HEcm_tab(1:Max_tab_E,0:4),
12493 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12494C global event kinematics and particle IDs
12495 INTEGER IFPAP,IFPAB
12496 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12497 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12498C obsolete cut-off information
12499 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12500 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12501C event weights and generated cross section
12502 INTEGER IPOWGC,ISWCUT,IVWGHT
12503 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12504 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12505 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12506C cut probability distribution
12507 INTEGER IEETA1,IIMAX,KKMAX
12508 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12509 INTEGER IEEMAX,IMAX,KMAX
12510 REAL PROB
12511 DOUBLE PRECISION EPTAB
12512 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12513 & IEEMAX,IMAX,KMAX
12514C energy-interpolation table
12515 INTEGER IEETA2
12516 PARAMETER ( IEETA2 = 20 )
12517 INTEGER ISIMAX
12518 DOUBLE PRECISION SIGTAB,SIGECM
12519 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12520
12521 CHARACTER*15 PHO_PNAME
12522 DIMENSION ECMF(4)
12523
12524 DATA XMPOM / 0.766D0 /
12525
12526C initialize fragmentation
12527 CALL PHO_FRAINI(ISWMDL(6))
12528
12529C reset interpolation tables
12530 DO 50 I=1,4
12531 DO 60 J=1,10
12532 DO 70 K=1,70
12533 SIGTAB(I,K,J) = 0.D0
12534 70 CONTINUE
12535 SIGECM(I,J) = 0.D0
12536 60 CONTINUE
12537 50 CONTINUE
12538
12539C max. number of allowed colors (large N expansion)
12540 IC1 = 0
12541 IC2 = 10000
12542 CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12543
12544C lower energy limit of initialization
12545 ETABLO = PARMDL(19)
12546 IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12547
12548 WRITE(LO,'(/,1X,A,2F12.1)')
12549 & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12550 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12551 & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12552 & PMASS(1),PVIRT(1)
12553 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12554 & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12555 & PMASS(2),PVIRT(2)
12556
12557C cuts on probabilities of multiple interactions
12558 IMAX = MIN(IPAMDL(32),IIMAX)
12559 KMAX = MIN(IPAMDL(33),KKMAX)
12560 AH = 2.D0*PTCUT(1)/ECM
12561 IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12562 KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12563
12564C hard interpolation table
12565 ECMF(1) = ECM
12566 ECMF(2) = 0.9D0*ECMF(1)
12567 ECMF(3) = ECMF(2)
12568 ECMF(4) = ECMF(2)
12569 do k=1,4
12570 IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12571 IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12572 IF(ECMF(k).LT.50.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12573 IF(ECMF(k).LT.10.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12574 enddo
12575
12576C initialization of hard scattering for all channels and cutoffs
12577 IF(HSWCUT(5).GT.PARMDL(36)) CALL PHO_HARMCI(-1,ECMF(1))
12578 I0 = 4
12579 IF(ISWMDL(2).EQ.0) I0 = 1
12580 DO 110 I=I0,1,-1
12581 CALL PHO_HARMCI(I,ECMF(I))
12582 110 CONTINUE
12583
12584C dimension of interpolation table of cut probabilities
12585 IEEMAX = MIN(IPAMDL(31),IEETA1)
12586 IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12587 IF(ECM.LT.50.D0) IEEMAX = MIN(IEEMAX,10)
12588 IF(ECM.LT.10.D0) IEEMAX = MIN(IEEMAX,5)
12589 ISIMAX = IEEMAX
12590
12591C calculate probability distribution
12592 I0 = 4
12593 IFT1 = IFPAP(1)
12594 IFT2 = IFPAP(2)
12595 XMT1 = PMASS(1)
12596 XMT2 = PMASS(2)
12597 XVT1 = PVIRT(1)
12598 XVT2 = PVIRT(2)
12599 IF(ISWMDL(2).EQ.0) I0 = 1
12600 DO 150 IP=I0,1,-1
12601 ECMPRO = ECMF(IP)*1.001D0
12602 IF(IP.EQ.4) THEN
12603 IFPAP(1) = 990
12604 IFPAP(2) = 990
12605 PMASS(1) = XMPOM
12606 PMASS(2) = XMPOM
12607 PVIRT(1) = 0.D0
12608 PVIRT(2) = 0.D0
12609 ELSE IF(IP.EQ.3) THEN
12610 IFPAP(1) = IFT2
12611 IFPAP(2) = 990
12612 PMASS(1) = XMT2
12613 PMASS(2) = XMPOM
12614 PVIRT(1) = XVT2
12615 PVIRT(2) = 0.D0
12616 ELSE IF(IP.EQ.2) THEN
12617 IFPAP(1) = IFT1
12618 IFPAP(2) = 990
12619 PMASS(1) = XMT1
12620 PMASS(2) = XMPOM
12621 PVIRT(1) = XVT1
12622 PVIRT(2) = 0.D0
12623 ELSE
12624 IFPAP(1) = IFT1
12625 IFPAP(2) = IFT2
12626 PMASS(1) = XMT1
12627 PMASS(2) = XMT2
12628 PVIRT(1) = XVT1
12629 PVIRT(2) = XVT2
12630 ENDIF
12631 IF(IEEMAX.GT.1) THEN
12632 IF(IP.EQ.1) THEN
12633 ELMIN = LOG(ETABLO)
12634 ELSE
12635 ELMIN = LOG(2.5D0)
12636 ENDIF
12637 EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12638 DO 100 I=1,IEEMAX
12639 ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12640 CALL PHO_PRBDIS(IP,ECMPRO,I)
12641 100 CONTINUE
12642 ELSE
12643 CALL PHO_PRBDIS(IP,ECMPRO,1)
12644 ENDIF
12645
12646C debug output of cross section tables
12647 IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12648 IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12649 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12650 &'Table of total cross sections (mb) for particle combination',IP,
12651 &' Ecm SIGtot SIGela SIGine SIGqel SIGsd1 SIGsd2 SIGdd',
12652 &'-------------------------------------------------------------'
12653 DO 200 I=1,IEEMAX
12654 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12655 & SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12656 & SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12657 & SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12658 & SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12659 200 CONTINUE
12660 201 CONTINUE
12661 IF(IDEB(62).GE.2) THEN
12662 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12663 &'Table of partial x-sections (mb) for particle combination',IP,
12664 &' Ecm SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL SIGDDH SIGCDF',
12665 &'--------------------------------------------------------------'
12666 DO 205 I=1,IEEMAX
12667 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12668 & SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12669 & SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12670 205 CONTINUE
12671 ENDIF
12672 IF(IDEB(62).GE.2) THEN
12673 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12674 &'Table of born graph x-sections (mb) for particle combination',IP,
12675 &' Ecm SIGSVDM SIGHRES SIGHDIR SIGTR1 SIGTR2 SIGLOO SIGDPO',
12676 &'-------------------------------------------------------------'
12677 DO 210 I=1,IEEMAX
12678 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12679 & SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12680 & SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12681 & SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12682 & SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12683 & +SIGTAB(IP,68,I)
12684 210 CONTINUE
12685 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12686 &'Table of unitarized x-sections (mb) for particle combination',IP,
12687 &' Ecm SIGSVDM SIGHVDM SIGTR1 SIGTR2 SIGLOO SIGDPO SLOPE',
12688 &'-------------------------------------------------------------'
12689 DO 215 I=1,IEEMAX
12690 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12691 & SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12692 & SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12693 215 CONTINUE
12694 ENDIF
12695 IF(IDEB(62).GE.1) THEN
12696 WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12697 &'Table of expected average number of cuts in non-diff events:',
12698 &' for max. number of cuts soft/hard:',IMAX,KMAX,
12699 &' Ecm PTCUT SIGNDF POM-S POM-H REG-S',
12700 &'---------------------------------------------'
12701 DO 220 I=1,IEEMAX
12702 WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12703 & SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12704 & SIGTAB(IP,76,I)
12705 220 CONTINUE
12706 IF(IP.EQ.1) THEN
12707 WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12708 & 'Table of rapidity gap survival probability (high-mass diff.):',
12709 & ' Ecm Spro-sd1 Spro-sd2 Spro-dd Spro-cd',
12710 & '---------------------------------------------------'
12711 DO 230 I=1,IEEMAX
12712 IF(SIGECM(IP,I).GT.10.D0) THEN
12713 SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12714 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12715 SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12716 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12717 SPRDD = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12718 & +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12719 & +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12720 SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12721 & +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12722 WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12723 & SPRSD1,SPRSD2,SPRDD,SPRCDF
12724 ENDIF
12725 230 CONTINUE
12726 ENDIF
12727 ENDIF
12728 ENDIF
12729 150 CONTINUE
12730
12731C simulate only hard scatterings
12732 IF(ISWMDL(2).EQ.0) THEN
12733 WRITE(LO,'(2(/1X,A))')
12734 & 'WARNING: generation of hard scatterings only!',
12735 & '============================================='
12736 DO 151 I=2,7
12737 IPRON(I,1) = 0
12738 151 CONTINUE
12739 DO 152 K=2,4
12740 DO 153 I=1,15
12741 IPRON(I,K) = 0
12742 153 CONTINUE
12743 152 CONTINUE
12744 SIGGEN(4) = 0.D0
12745 DO 160 I=1,IEEMAX
12746 SIGMAX = 0.D0
12747 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12748 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12749 IF(SIGMAX.GT.SIGGEN(4)) THEN
12750 ISIGM = I
12751 SIGGEN(4) = SIGMAX
12752 ENDIF
12753 160 CONTINUE
12754 ELSE
12755 WRITE(LO,'(2(/1X,A))')
12756 & 'activated processes, cross section',
12757 & '----------------------------------'
12758 WRITE(LO,'(5X,A,I3,2X,3I3)')
12759 & ' nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12760 WRITE(LO,'(5X,A,I3,2X,3I3)')
12761 & ' elastic scattering',(IPRON(2,K),K=1,4)
12762 WRITE(LO,'(5X,A,I3,2X,3I3)')
12763 & 'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12764 WRITE(LO,'(5X,A,I3,2X,3I3)')
12765 & ' double pomeron processes',(IPRON(4,K),K=1,4)
12766 WRITE(LO,'(5X,A,I3,2X,3I3)')
12767 & ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12768 WRITE(LO,'(5X,A,I3,2X,3I3)')
12769 & ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12770 WRITE(LO,'(5X,A,I3,2X,3I3)')
12771 & ' double diffract. processes',(IPRON(7,K),K=1,4)
12772 WRITE(LO,'(5X,A,I3,2X,3I3)')
12773 & ' direct photon processes',(IPRON(8,K),K=1,4)
12774
12775C calculate effective cross section
12776 SIGGEN(4) = 0.D0
12777 DO 165 I=1,IEEMAX
12778 CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12779 & PVIRT(1),PVIRT(2))
12780 SIGMAX = 0.D0
12781 if(iswmdl(2).ge.1) then
12782 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12783 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12784 & -SIGLDD-SIGHDD-SIGDIR
12785 IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12786 IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12787 IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12788 IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12789 IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12790 IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12791 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12792 else
12793 IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12794 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12795 endif
12796 IF(SIGMAX.GT.SIGGEN(4)) THEN
12797 ISIGM = I
12798 SIGGEN(4) = SIGMAX
12799 ENDIF
12800 165 CONTINUE
12801 ENDIF
12802
12803C debug output
12804 IF(SIGGEN(4).LT.1.D-20) THEN
12805 WRITE(LO,'(//1X,A)')
12806 & 'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12807 STOP
12808 ENDIF
12809 WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12810 & SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12811 WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12812
12813 END
12814
12815*$ CREATE PHO_REJSTA.FOR
12816*COPY PHO_REJSTA
12817CDECK ID>, PHO_REJSTA
12818 SUBROUTINE PHO_REJSTA(IMODE)
12819C********************************************************************
12820C
12821C MC rejection counting
12822C
12823C input IMODE -1 initialization
12824C -2 output of statistics
12825C
12826C********************************************************************
12827
12828 IMPLICIT NONE
12829
12830 SAVE
12831
12832C input/output channels
12833 INTEGER LI,LO
12834 COMMON /POINOU/ LI,LO
12835C event debugging information
12836 INTEGER NMAXD
12837 PARAMETER (NMAXD=100)
12838 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12839 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12840 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12841 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12842C internal rejection counters
12843 INTEGER NMXJ
12844 PARAMETER (NMXJ=60)
12845 CHARACTER*10 REJTIT
12846 INTEGER IFAIL
12847 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12848
12849 INTEGER IMODE
12850
12851 INTEGER I
12852
12853C initialization
12854 IF(IMODE.EQ.-1) THEN
12855 DO 100 I=1,NMXJ
12856 IFAIL(I) = 0
12857 100 CONTINUE
12858C
12859 REJTIT(1) = 'PARTON ALL'
12860 REJTIT(2) = 'STDPAR ALL'
12861 REJTIT(3) = 'STDPAR DPO'
12862 REJTIT(4) = 'POMSCA ALL'
12863 REJTIT(5) = 'POMSCA INT'
12864 REJTIT(6) = 'POMSCA KIN'
12865 REJTIT(7) = 'DIFDIS ALL'
12866 REJTIT(8) = 'POSPOM ALL'
12867 REJTIT(9) = 'HRES.DIF.1'
12868 REJTIT(10) = 'HDIR.DIF.1'
12869 REJTIT(11) = 'HRES.DIF.2'
12870 REJTIT(12) = 'HDIR.DIF.2'
12871 REJTIT(13) = 'DIFDIS INT'
12872 REJTIT(14) = 'HADRON SP2'
12873 REJTIT(15) = 'HADRON SP3'
12874 REJTIT(16) = 'HARDIR ALL'
12875 REJTIT(17) = 'HARDIR INT'
12876 REJTIT(18) = 'HARDIR KIN'
12877 REJTIT(19) = 'MCHECK BAR'
12878 REJTIT(20) = 'MCHECK MES'
12879 REJTIT(21) = 'DIF.DISS.1'
12880 REJTIT(22) = 'DIF.DISS.2'
12881 REJTIT(23) = 'STRFRA ALL'
12882 REJTIT(24) = 'MSHELL CHA'
12883 REJTIT(25) = 'PARTPT SOF'
12884 REJTIT(26) = 'PARTPT HAR'
12885 REJTIT(27) = 'INTRINS KT'
12886 REJTIT(28) = 'HACHEK DIR'
12887 REJTIT(29) = 'HACHEK RES'
12888 REJTIT(30) = 'STRING ALL'
12889 REJTIT(31) = 'POMSCA INT'
12890 REJTIT(32) = 'DIFF SLOPE'
12891 REJTIT(33) = 'GLU2QU ALL'
12892 REJTIT(34) = 'MASCOR ALL'
12893 REJTIT(35) = 'PARCOR ALL'
12894 REJTIT(36) = 'MSHELL PAR'
12895 REJTIT(37) = 'MSHELL ALL'
12896 REJTIT(38) = 'POMCOR ALL'
12897 REJTIT(39) = 'DB-POM KIN'
12898 REJTIT(40) = 'DB-POM ALL'
12899 REJTIT(41) = 'SOFTXX ALL'
12900 REJTIT(42) = 'SOFTXX PSP'
12901
12902C write output
12903 ELSE IF(IMODE.EQ.-2) THEN
12904 WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12905 & '--------------------------------'
12906 DO 300 I=1,NMXJ
12907 IF(IFAIL(I).GT.0)
12908 & WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12909 300 CONTINUE
12910 ELSE
12911 WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12912 ENDIF
12913
12914 END
12915
12916*$ CREATE PHO_POSPOM.FOR
12917*COPY PHO_POSPOM
12918CDECK ID>, PHO_POSPOM
12919 SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12920C***********************************************************************
12921C
12922C registration of one cut pomeron (soft/semihard)
12923C
12924C input: IP particle combination the pomeron belongs to
12925C IND1,2 position of X values in /POSOFT/
12926C 1 corresponds to a valence-pomeron
12927C IGEN production process of mother particles
12928C IPOM pomeron number
12929C KCUT total number of cut pomerons and reggeons
12930C
12931C output: ISWAP exchange of x values
12932C IND1,2 increased by the number of partons belonging
12933C to the generated pomeron cut
12934C IREJ success/failure
12935C
12936C**********************************************************************
12937 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12938 SAVE
12939
12940 PARAMETER ( DEPS = 1.D-8 )
12941
12942C input/output channels
12943 INTEGER LI,LO
12944 COMMON /POINOU/ LI,LO
12945C event debugging information
12946 INTEGER NMAXD
12947 PARAMETER (NMAXD=100)
12948 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12949 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12950 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12951 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12952C internal rejection counters
12953 INTEGER NMXJ
12954 PARAMETER (NMXJ=60)
12955 CHARACTER*10 REJTIT
12956 INTEGER IFAIL
12957 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12958C model switches and parameters
12959 CHARACTER*8 MDLNA
12960 INTEGER ISWMDL,IPAMDL
12961 DOUBLE PRECISION PARMDL
12962 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12963C general process information
12964 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12965 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12966C global event kinematics and particle IDs
12967 INTEGER IFPAP,IFPAB
12968 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12969 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12970C data of c.m. system of Pomeron / Reggeon exchange
12971 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12972 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12973 & SIDP,CODP,SIFP,COFP
12974 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12975 & SIDP,CODP,SIFP,COFP,NPOSP(2),
12976 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
12977C obsolete cut-off information
12978 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12979 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12980C energy-interpolation table
12981 INTEGER IEETA2
12982 PARAMETER ( IEETA2 = 20 )
12983 INTEGER ISIMAX
12984 DOUBLE PRECISION SIGTAB,SIGECM
12985 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12986C light-cone x fractions and c.m. momenta of soft cut string ends
12987 INTEGER MAXSOF
12988 PARAMETER ( MAXSOF = 50 )
12989 INTEGER IJSI2,IJSI1
12990 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12991 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12992 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12993 & IJSI1(MAXSOF),IJSI2(MAXSOF)
12994
12995C standard particle data interface
12996 INTEGER NMXHEP
12997
12998 PARAMETER (NMXHEP=4000)
12999
13000 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13001 DOUBLE PRECISION PHEP,VHEP
13002 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13003 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13004 & VHEP(4,NMXHEP)
13005C extension to standard particle data interface (PHOJET specific)
13006 INTEGER IMPART,IPHIST,ICOLOR
13007 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13008
13009C table of particle indices for recursive PHOJET calls
13010 INTEGER MAXIPX
13011 PARAMETER ( MAXIPX = 100 )
13012 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
13013 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
13014 & IPOIX1,IPOIX2,IPOIX3
13015
13016 DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
13017
13018 IREJ = 0
13019 ISWAP = 0
13020 JM1 = NPOSP(1)
13021 JM2 = NPOSP(2)
13022 INDX1 = IND1
13023 INDX2 = IND2
13024 EA1 = XS1(IND1)*ECMP/2.D0
13025 EA2 = XS1(IND1+1)*ECMP/2.D0
13026 EB1 = XS2(IND2)*ECMP/2.D0
13027 EB2 = XS2(IND2+1)*ECMP/2.D0
13028 CMASS1 = MIN(EA1,EA2)
13029 CMASS2 = MIN(EB1,EB2)
13030
13031C debug output
13032 IF(IDEB(9).GE.20) THEN
13033 WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
13034 & 'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
13035 WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
13036 & CMASS1,CMASS2
13037 ENDIF
13038
13039C flavours
13040 IF(IND1.EQ.1) THEN
13041 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
13042 ELSE
13043 CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
13044 ENDIF
13045 IF(IND2.EQ.1) THEN
13046 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
13047 ELSE
13048 CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
13049 ENDIF
13050 DO 75 I=1,4
13051 P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
13052 P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
13053 75 CONTINUE
13054
13055C pomeron resolved?
13056 IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
13057C find energy for cross section calculation
13058 IF(IPAMDL(16).EQ.2) THEN
13059 ESUB = ECMP
13060 ELSE IF(IPAMDL(16).EQ.3) THEN
13061 IF(IPROCE.EQ.1) THEN
13062 ESUB = ECM
13063 ELSE
13064 ESUB = ECMP
13065 ENDIF
13066 ELSE
13067 ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
13068 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
13069 ENDIF
13070C load cross sections from interpolation table
13071 IF(ESUB.LE.SIGECM(IP,1)) THEN
13072 I1 = 1
13073 I2 = 2
13074 ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
13075 DO 50 I=2,ISIMAX
13076 IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
13077 50 CONTINUE
13078 200 CONTINUE
13079 I1 = I-1
13080 I2 = I
13081 ELSE
13082 WRITE(LO,'(/1X,A,2E12.3)')
13083 & 'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
13084 CALL PHO_PREVNT(-1)
13085 I1 = ISIMAX-1
13086 I2 = ISIMAX
13087 ENDIF
13088 FAC2=0.D0
13089 IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
13090 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
13091 FAC1=1.D0-FAC2
13092C calculate weights
13093* WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13094* WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13095* WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13096* WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13097* WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13098* WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13099
13100 WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13101 & +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13102 WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13103 WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13104 WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13105 & +SIGTAB(IP,64,I2))
13106 & +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13107 & +SIGTAB(IP,64,I1))
13108 WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13109 & +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13110 & +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13111 & +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13112
13113C one-pomeron cut
13114 WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13115C central diff. cut
13116 WGX(2) = WGXCDF
13117C diff. diss. of particle 1
13118 WGX(3) = WGXHSD(1)
13119C diff. diss. of particle 2
13120 WGX(4) = WGXHSD(2)
13121C double diff. dissociation
13122 WGX(5) = WGXHDD
13123C two-pomeron cut
13124 WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13125
13126* IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13127* WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13128* & ' unitarity bound reached for ',IP,ESUB,WGX(1)
13129* WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13130* WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13131* WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13132* ENDIF
13133
13134 SUM = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13135
13136C selection loop
13137 205 CONTINUE
13138 XI = DT_RNDM(SUM)*SUM
13139 I = 0
13140 SUM = 0.D0
13141 210 CONTINUE
13142 I = I+1
13143 SUM = SUM+WGX(I)
13144 IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13145C phase space correction
13146 IF(I.NE.1) THEN
13147 ISAM = 4
13148 IF(I.EQ.6) ISAM = 8
13149 PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13150* IF(DT_RNDM(SUM).GT.PACC) I=1
13151 IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13152 ENDIF
13153
13154C do not generate diffraction for events with only one cut pomeron
13155 IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13156
13157C do not generate recursive calls for remants with
13158C diquark-anti-diquark flavour contents
13159 if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13160 if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13161
13162C debug output
13163 IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13164 & 'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13165
13166 IF(I.GT.1) THEN
13167C second scattering needed
13168 CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13169 CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13170 IDPD1 = IPHO_ID2PDG(IDHA1)
13171 IDPD2 = IPHO_ID2PDG(IDHA2)
13172
13173 if(INDX1.eq.1) then
13174 if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13175 & IGEN_had = IGEN
13176 else
13177 IGEN_had = -IGEN
13178 endif
13179 CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13180 & IPOM,IGEN_had,0,0,IPOS1,1)
13181
13182 if(INDX2.eq.1) then
13183 if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13184 & IGEN_had = IGEN
13185 else
13186 IGEN_had = -IGEN
13187 endif
13188 CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13189 & IPOM,IGEN_had,0,0,IPOS1,1)
13190
13191 IND1 = IND1+2
13192 IND2 = IND2+2
13193C update index
13194 IPOIX2 = IPOIX2+1
13195
13196 IF(IPOIX2.GT.MAXIPX) THEN
13197 WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13198 & '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13199 IREJ = 1
13200 RETURN
13201 ENDIF
13202
13203 IPORES(IPOIX2) = I+2
13204 IPOPOS(1,IPOIX2) = IPOS1-1
13205 IPOPOS(2,IPOIX2) = IPOS1
13206 RETURN
13207 ENDIF
13208 ENDIF
13209
13210 100 CONTINUE
13211 IF(ISWMDL(12).EQ.0) THEN
13212C sample colors
13213 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13214 CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13215
13216C purely gluonic pomeron or sea strings formed by gluons
13217
13218 IF( ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13219 & .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13220 IFLA1 = 21
13221 IFLA2 = 21
13222 ENDIF
13223 IF( ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13224 & .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13225 IFLB1 = 21
13226 IFLB2 = 21
13227 ENDIF
13228
13229C color connection
13230 IF(IFLA1.NE.21) THEN
13231 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13232 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13233 & CALL PHO_SWAPI(ICA1,ICD1)
13234 ENDIF
13235 IF(IFLB1.NE.21) THEN
13236 IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13237 & .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13238 & CALL PHO_SWAPI(ICB1,ICC1)
13239 ENDIF
13240 ISWAP = 0
13241 IF(ICA1*ICB1.GT.0) THEN
13242 IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13243 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13244 CALL PHO_SWAPI(IFLA1,IFLA2)
13245 CALL PHO_SWAPI(ICA1,ICD1)
13246 ELSE
13247 CALL PHO_SWAPI(IFLB1,IFLB2)
13248 CALL PHO_SWAPI(ICB1,ICC1)
13249 ENDIF
13250 ELSE IF(IND1.NE.1) THEN
13251 CALL PHO_SWAPI(IFLA1,IFLA2)
13252 CALL PHO_SWAPI(ICA1,ICD1)
13253 ELSE IF(IND2.NE.1) THEN
13254 CALL PHO_SWAPI(IFLB1,IFLB2)
13255 CALL PHO_SWAPI(ICB1,ICC1)
13256 ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13257 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13258 CALL PHO_SWAPI(IFLA1,IFLA2)
13259 CALL PHO_SWAPI(ICA1,ICD1)
13260 ELSE
13261 CALL PHO_SWAPI(IFLB1,IFLB2)
13262 CALL PHO_SWAPI(ICB1,ICC1)
13263 ENDIF
13264 ELSE IF(IFLA1.EQ.-IFLA2) THEN
13265 CALL PHO_SWAPI(IFLA1,IFLA2)
13266 CALL PHO_SWAPI(ICA1,ICD1)
13267 ELSE IF(IFLB1.EQ.-IFLB2) THEN
13268 CALL PHO_SWAPI(IFLB1,IFLB2)
13269 CALL PHO_SWAPI(ICB1,ICC1)
13270 ELSE
13271 ISWAP = 1
13272 IF(IDEB(9).GE.5) THEN
13273 WRITE(LO,'(1X,A,I12)')
13274 & 'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13275 WRITE(LO,'(5X,A,4I7)')
13276 & 'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13277 WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13278 ENDIF
13279 ENDIF
13280 ENDIF
13281
13282C registration
13283
13284C purely gluonic pomeron or sea strings formed by gluons
13285 IF(IFLA1.EQ.21) THEN
13286 CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13287 & IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13288 IND1 = IND1+2
13289
13290C strings formed by quarks
13291 ELSE
13292C valence quark labels
13293 IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13294 & .and.(IDHEP(JM1).NE.990)) THEN
13295 ICA2 = 1
13296 ICD2 = 1
13297 ENDIF
13298C registration
13299 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13300 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13301 & ICA2,IPOS1,1)
13302 IND1 = IND1+1
13303 CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13304 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13305 & ICD2,IPOS,1)
13306 IND1 = IND1+1
13307
13308 ENDIF
13309
13310C purely gluonic pomeron or sea strings formed by gluons
13311 IF(IFLB1.EQ.21) THEN
13312 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13313 & IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13314 IND2 = IND2+2
13315
13316C strings formed by quarks
13317 ELSE
13318C valence quark labels
13319 IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13320 & .and.(IDHEP(JM2).NE.990)) THEN
13321 ICB2 = 1
13322 ICC2 = 1
13323 ENDIF
13324C registration
13325 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13326 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13327 & ICB2,IPOS,1)
13328 IND2 = IND2+1
13329 CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13330 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13331 & ICC2,IPOS2,1)
13332 IND2 = IND2+1
13333
13334 ENDIF
13335
13336C soft pt assignment
13337 IF(ISWMDL(18).EQ.0) THEN
13338 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13339 IF(IREJ.NE.0) THEN
13340 IFAIL(25) = IFAIL(25)+1
13341 RETURN
13342 ENDIF
13343 ENDIF
13344 ELSE
13345* CALL PHO_BFKL(P1,P2,IPART,IREJ)
13346* IF(IREJ.NE.0) RETURN
13347 ENDIF
13348
13349 END
13350
13351*$ CREATE PHO_HADSP2.FOR
13352*COPY PHO_HADSP2
13353CDECK ID>, PHO_HADSP2
13354 SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13355C***********************************************************************
13356C
13357C split hadron momentum XMAX into two partons using
13358C lower cut-off: AS
13359C
13360C input: IFLB compressed particle code of particle to split
13361C XS1 sum of x values already selected
13362C XMAX maximal x possible
13363C
13364C output: XS1 new sum of x values (without first one)
13365C XSOFT1 field of selected x values
13366C
13367C**********************************************************************
13368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13369 SAVE
13370
13371 PARAMETER ( DEPS = 1.D-8 )
13372
13373 DIMENSION XSOFT1(50)
13374
13375C input/output channels
13376 INTEGER LI,LO
13377 COMMON /POINOU/ LI,LO
13378C event debugging information
13379 INTEGER NMAXD
13380 PARAMETER (NMAXD=100)
13381 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13382 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13383 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13384 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13385C internal rejection counters
13386 INTEGER NMXJ
13387 PARAMETER (NMXJ=60)
13388 CHARACTER*10 REJTIT
13389 INTEGER IFAIL
13390 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13391C data on most recent hard scattering
13392 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13393 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13394 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13395 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13396 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13397 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13398 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13399 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13400 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13401
13402C model exponents
13403 DATA PVMES1 /-0.5D0/
13404 DATA PVMES2 /-0.5D0/
13405 DATA PVBAR1 / 1.5D0/
13406 DATA PVBAR2 /-0.5D0/
13407C
13408 IREJ = 0
13409 ITMAX = 100
13410C
13411C mesonic particle
13412 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13413 XPOT1 = PVMES1+1.D0
13414 XPOT2 = PVMES2+1.D0
13415C baryonic particle
13416 ELSE
13417 XPOT1 = PVBAR1+1.D0
13418 XPOT2 = PVBAR2+1.D0
13419 ENDIF
13420 ITER = 0
13421 XREST= 1.D0-XS1
13422C selection loop
13423 100 CONTINUE
13424 ITER = ITER+1
13425 IF(ITER.GE.ITMAX) THEN
13426 IF(IDEB(39).GE.3) THEN
13427 WRITE(LO,'(1X,A,I8)')
13428 & 'PHO_HADSP2: REJECTION (ITER)',ITER
13429 WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13430 ENDIF
13431 IFAIL(14) = IFAIL(14)+1
13432 IREJ = 1
13433 RETURN
13434 ENDIF
13435 ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13436 IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13437 XSS1 = XS1 + ZZ
13438 IF((1.D0-XSS1).LT.AS) GOTO 100
13439C
13440 XS1 = XSS1
13441 XSOFT1(1) = 1.D0-XSS1
13442 XSOFT1(2) = ZZ
13443C debug output
13444 IF(IDEB(39).GE.10) THEN
13445 WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13446 WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS X1,X2:',
13447 & XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13448 ENDIF
13449 END
13450
13451*$ CREATE PHO_HADSP3.FOR
13452*COPY PHO_HADSP3
13453CDECK ID>, PHO_HADSP3
13454 SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13455C***********************************************************************
13456C
13457C split hadron momentum XMAX into diquark & quark pair
13458C using lower cut-off: AS
13459C
13460C input: IFLB compressed particle code of particle to split
13461C XS1 sum of x values already selected
13462C XMAX maximal x possible
13463C
13464C output: XS1 new sum of x values
13465C XSOFT1 field of selected x values
13466C
13467C
13468C**********************************************************************
13469 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13470 SAVE
13471 PARAMETER ( DEPS = 1.D-8 )
13472
13473 DIMENSION XSOFT1(50),XSOFT2(50)
13474
13475C input/output channels
13476 INTEGER LI,LO
13477 COMMON /POINOU/ LI,LO
13478C event debugging information
13479 INTEGER NMAXD
13480 PARAMETER (NMAXD=100)
13481 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13482 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13483 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13484 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13485C internal rejection counters
13486 INTEGER NMXJ
13487 PARAMETER (NMXJ=60)
13488 CHARACTER*10 REJTIT
13489 INTEGER IFAIL
13490 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13491C data of c.m. system of Pomeron / Reggeon exchange
13492 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13493 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13494 & SIDP,CODP,SIFP,COFP
13495 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13496 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13497 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13498
13499 DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13500
13501C model exponents
13502 DATA PVMES1 /-0.5D0/
13503 DATA PVMES2 /-0.5D0/
13504 DATA PSMES /-0.99D0/
13505 DATA PVBAR1 / 1.5D0/
13506 DATA PVBAR2 /-0.5D0/
13507 DATA PSBAR /-0.99D0/
13508C
13509 IREJ = 0
13510C
13511C determine exponents
13512C particle 1
13513C
13514 XMMIN = 0.3D0/ECMP
13515 XBMIN = 1.6D0/ECMP
13516C mesonic particle
13517 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13518 XPOT1(1) = PVMES1
13519 XMIN(1,1) = XMMIN
13520 XPOT1(2) = PVMES2
13521 XMIN(1,2) = XMMIN
13522 XPOT1(3) = PSMES
13523 XMIN(1,3) = XMMIN
13524C baryonic particle
13525 ELSE
13526 XPOT1(1) = PVBAR1
13527 XMIN(1,1) = XBMIN
13528 XPOT1(2) = PVBAR2
13529 XMIN(1,2) = XMMIN
13530 XPOT1(3) = PSBAR
13531 XMIN(1,3) = XMMIN
13532 ENDIF
13533C particle 2
13534C mesonic particle
13535 XPOT2(1) = PVMES1
13536 XMIN(2,1) = XMMIN
13537 XPOT2(2) = PVMES2
13538 XMIN(2,2) = XMMIN
13539 XPOT2(3) = PSMES
13540 XMIN(2,3) = XMMIN
13541C
13542 XDUM1 = 0.01D0
13543 XDUM2 = 0.99D0
13544 CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13545 & XSOFT1,XSOFT2,IREJ)
13546C rejection?
13547 IF(IREJ.NE.0) THEN
13548 IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13549 & 'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13550 IFAIL(15) = IFAIL(15)+1
13551 IREJ = 1
13552 RETURN
13553 ENDIF
13554C debug output
13555 IF(IDEB(74).GE.10) THEN
13556 WRITE(LO,'(1X,A,I6,2E12.4)')
13557 & 'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13558 DO 100 I=1,3
13559 WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13560 100 CONTINUE
13561 ENDIF
13562
13563 END
13564
13565*$ CREATE PHO_SOFTXX.FOR
13566*COPY PHO_SOFTXX
13567CDECK ID>, PHO_SOFTXX
13568 SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13569 & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13570C***********************************************************************
13571C
13572C select soft x values
13573C
13574C input: JM1,JM2 mother particle index in POEVT1
13575C (0 flavour not known before)
13576C MSPAR1,2 number of x values to select
13577C IVAL1,2 number valence quarks involved in hard
13578C scattering (0,1,2)
13579C MSM1,2 minimum number of soft x to get sampled
13580C XSUM1,2 sum of all x values samples up this call
13581C XMAX1,2 max. x value
13582C
13583C output XSUM1,2 new sum of x-values sampled
13584C XS1,2 field containing sampled x values
13585C
13586C x values of valence partons are first given
13587C
13588C***********************************************************************
13589 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13590 SAVE
13591
13592C input/output channels
13593 INTEGER LI,LO
13594 COMMON /POINOU/ LI,LO
13595C event debugging information
13596 INTEGER NMAXD
13597 PARAMETER (NMAXD=100)
13598 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13599 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13600 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13601 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13602C internal rejection counters
13603 INTEGER NMXJ
13604 PARAMETER (NMXJ=60)
13605 CHARACTER*10 REJTIT
13606 INTEGER IFAIL
13607 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13608C model switches and parameters
13609 CHARACTER*8 MDLNA
13610 INTEGER ISWMDL,IPAMDL
13611 DOUBLE PRECISION PARMDL
13612 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13613C data of c.m. system of Pomeron / Reggeon exchange
13614 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13615 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13616 & SIDP,CODP,SIFP,COFP
13617 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13618 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13619 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13620
13621C standard particle data interface
13622 INTEGER NMXHEP
13623
13624 PARAMETER (NMXHEP=4000)
13625
13626 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13627 DOUBLE PRECISION PHEP,VHEP
13628 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13629 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13630 & VHEP(4,NMXHEP)
13631C extension to standard particle data interface (PHOJET specific)
13632 INTEGER IMPART,IPHIST,ICOLOR
13633 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13634
13635C nucleon-nucleus / nucleus-nucleus interface to DPMJET
13636 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13637 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13638 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13639 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13640C obsolete cut-off information
13641 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13642 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13643C data on most recent hard scattering
13644 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13645 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13646 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13647 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13648 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13649 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13650 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13651 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13652 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13653
13654 DIMENSION XS1(*),XS2(*)
13655
13656 INTEGER MAXPOT
13657 PARAMETER ( MAXPOT = 50 )
13658 DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13659
13660 IREJ = 0
13661
13662 MSMAX = MAX(MSPAR1,MSPAR2)
13663 MSMIN = MAX(MSM1,MSM2)
13664
13665 IF(MSMAX.GT.MAXPOT) THEN
13666 WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13667 & 'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13668 IREJ = 1
13669 RETURN
13670 ENDIF
13671
13672C determine exponents
13673 IBAR1 = ipho_bar3(JM1,2)
13674 IBAR2 = ipho_bar3(JM2,2)
13675 ISWAP = 0
13676 IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13677C meson-baryon scattering (asymmetric sea)
13678 IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13679 PSBAR = PARMDL(53)
13680 PSMES = PARMDL(57)
13681 ELSE
13682 PSBAR = PARMDL(52)
13683 PSMES = PARMDL(56)
13684 ENDIF
13685
13686C lower limits for x sampling
13687 XMMINA = 2.D0*PARMDL(157)/ECMP
13688 XBMINA = 2.D0*PARMDL(158)/ECMP
13689 XSMINA = 2.D0*PARMDL(159)/ECMP
13690 XMIN1 = MAX(XSOMIN,AS/XMAX2)
13691 XMIN2 = MAX(XSOMIN,AS/XMAX1)
13692 XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13693 XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13694 XMIN1 = MAX(AS/XMAX2,XMIN1)
13695 XMIN2 = MAX(AS/XMAX1,XMIN2)
13696
13697C particle 1
13698 XMMIN1 = MAX(XMIN1,XMMINA)
13699 XBMIN1 = MAX(XMIN1,XBMINA)
13700 XSMIN1 = MAX(XMIN1,XSMINA)
13701C mesonic particle
13702 IF(IBAR1.EQ.0) THEN
13703 IF(IHFLS(1).EQ.0) THEN
13704 XPOT1(1) = PARMDL(62)
13705 XMIN(1,1) = XSMIN1
13706 XPOT1(2) = PARMDL(63)
13707 XMIN(1,2) = XSMIN1
13708 ELSE
13709 XPOT1(1) = PARMDL(54)
13710 XMIN(1,1) = XMMIN1
13711 XPOT1(2) = PARMDL(55)
13712 XMIN(1,2) = XMMIN1
13713 ENDIF
13714 DO 100 I=3-IVAL1,MSMAX
13715 XPOT1(I) = PSMES
13716 XMIN(1,I) = XSMIN1
13717 100 CONTINUE
13718C baryonic particle
13719 ELSE
13720 IF(IHFLS(1).EQ.0) THEN
13721 XPOT1(1) = PARMDL(62)
13722 XMIN(1,1) = XSMIN1
13723 XPOT1(2) = PARMDL(63)
13724 XMIN(1,2) = XSMIN1
13725 ELSE
13726 XPOT1(1) = PARMDL(50)
13727 XMIN(1,1) = XBMIN1
13728 XPOT1(2) = PARMDL(51)
13729 XMIN(1,2) = XMMIN1
13730 ENDIF
13731 DO 200 I=3-IVAL1,MSMAX
13732 XPOT1(I) = PSBAR
13733 XMIN(1,I) = XSMIN1
13734 200 CONTINUE
13735 ENDIF
13736
13737C particle 2
13738 XMMIN2 = MAX(XMIN2,XMMINA)
13739 XBMIN2 = MAX(XMIN2,XBMINA)
13740 XSMIN2 = MAX(XMIN2,XSMINA)
13741C mesonic particle
13742 IF(IBAR2.EQ.0) THEN
13743 IF(IHFLS(2).EQ.0) THEN
13744 XPOT2(1) = PARMDL(62)
13745 XMIN(2,1) = XSMIN2
13746 XPOT2(2) = PARMDL(63)
13747 XMIN(2,2) = XSMIN2
13748 ELSE
13749 XPOT2(1) = PARMDL(54)
13750 XMIN(2,1) = XMMIN2
13751 XPOT2(2) = PARMDL(55)
13752 XMIN(2,2) = XMMIN2
13753 ENDIF
13754 DO 300 I=3-IVAL2,MSMAX
13755 XPOT2(I) = PSMES
13756 XMIN(2,I) = XSMIN2
13757 300 CONTINUE
13758C baryonic particle
13759 ELSE
13760 IF(IHFLS(2).EQ.0) THEN
13761 XPOT2(1) = PARMDL(62)
13762 XMIN(2,1) = XSMIN2
13763 XPOT2(2) = PARMDL(63)
13764 XMIN(2,2) = XSMIN2
13765 ELSE
13766 XPOT2(1) = PARMDL(50)
13767 XMIN(2,1) = XBMIN2
13768 XPOT2(2) = PARMDL(51)
13769 XMIN(2,2) = XMMIN2
13770 ENDIF
13771 DO 400 I=3-IVAL2,MSMAX
13772 XPOT2(I) = PSBAR
13773 XMIN(2,I) = XSMIN2
13774 400 CONTINUE
13775 ENDIF
13776
13777 XSS1 = XSUM1
13778 XSS2 = XSUM2
13779 MSOFT = MSMAX
13780
13781C check limits (important for valences)
13782 IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13783 IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13784
13785 XMINS1 = XSS1
13786 IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13787 XMINS2 = XSS2
13788 IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13789 DO 10 I=1,MSOFT
13790 XMINS1 = XMINS1+XMIN(1,I)
13791 XMINS2 = XMINS2+XMIN(2,I)
13792 10 CONTINUE
13793 IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13794
13795C try to sample x values
13796 IF(IPAMDL(14).EQ.0) THEN
13797 IF(MSOFT.EQ.2) THEN
13798 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13799 & XS1,XS2,IREJ)
13800 ELSE IF(MSOFT.LT.5) THEN
13801 CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13802 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13803 ELSE
13804 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13805 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13806 ENDIF
13807 ELSE IF(IPAMDL(14).EQ.1) THEN
13808 IF(MSOFT.EQ.2) THEN
13809 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13810 & XS1,XS2,IREJ)
13811 ELSE
13812 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13813 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13814 ENDIF
13815 ELSE IF(IPAMDL(14).EQ.2) THEN
13816 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13817 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13818 ELSE IF(IPAMDL(14).EQ.3) THEN
13819 IF(MSOFT.EQ.2) THEN
13820 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13821 & XS1,XS2,IREJ)
13822 ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13823 CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13824 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13825 ELSE
13826 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13827 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13828 ENDIF
13829 ELSE
13830 WRITE(LO,'(/,1X,A,I3)')
13831 & 'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13832 STOP
13833 ENDIF
13834 IF(IREJ.NE.0) THEN
13835 IFAIL(41) = IFAIL(41)+1
13836 IF(IDEB(60).GE.2) THEN
13837 WRITE(LO,'(1X,A,I12,4I3)')
13838 & 'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13839 & KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13840 WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13841 & XSUM1,XSUM2,XMAX1,XMAX2
13842 ENDIF
13843 RETURN
13844 ENDIF
13845 IF(MSOFT.NE.MSMAX) THEN
13846 MSDIFF = MSMAX-MSOFT
13847 MSPAR1 = MSPAR1-MSDIFF
13848 MSPAR2 = MSPAR2-MSDIFF
13849 ENDIF
13850
13851C correct for different MSPAR numbers
13852 IF(MSOFT.NE.MSPAR1) THEN
13853 IF(MSPAR1.GT.1) THEN
13854 XDEL = 0.D0
13855 DO 500 I=MSPAR1+1,MSOFT
13856 XDEL = XDEL+XS1(I)
13857 500 CONTINUE
13858 XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13859 DO 550 I=2,MSPAR1
13860 XS1(I) = XS1(I)*XFAC
13861 550 CONTINUE
13862 XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13863 ELSE
13864 XSS1 = XSUM1
13865 ENDIF
13866 ENDIF
13867 IF(MSOFT.NE.MSPAR2) THEN
13868 IF(MSPAR2.GT.1) THEN
13869 XDEL = 0.D0
13870 DO 600 I=MSPAR2+1,MSOFT
13871 XDEL = XDEL+XS2(I)
13872 600 CONTINUE
13873 XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13874 DO 650 I=2,MSPAR2
13875 XS2(I) = XS2(I)*XFAC
13876 650 CONTINUE
13877 XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13878 ELSE
13879 XSS2 = XSUM2
13880 ENDIF
13881 ENDIF
13882
13883C first x entry
13884 XS1(1) = 1.D0 - XSS1
13885 XS2(1) = 1.D0 - XSS2
13886 XSUM1 = XSS1
13887 XSUM2 = XSS2
13888
13889C debug output
13890 IF(IDEB(60).GE.10) THEN
13891 WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13892 & 'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13893 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13894 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XS1/2 XPOT1/2 XMIN1/2'
13895 DO 30 I=1,MSOFT
13896 WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13897 & XMIN(1,I),XMIN(2,I)
13898 30 CONTINUE
13899 ENDIF
13900
13901 RETURN
13902
13903C not enough phase space
13904 1000 CONTINUE
13905
13906 IFAIL(42) = IFAIL(42)+1
13907 IREJ = 1
13908
13909C warning message
13910 IF(IDEB(60).GE.1) THEN
13911 WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13912 & 'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13913 & ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13914 & XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13915 WRITE(LO,'(1X,A,1P,3E11.3)')
13916 & 'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13917 WRITE(LO,'(1X,A,1P,3E11.3)')
13918 & 'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13919 WRITE(LO,'(1X,A,1P,3E11.3)')
13920 & 'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13921 WRITE(LO,'(1X,A)')
13922 & 'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13923 DO 27 I=1,MSOFT
13924 WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13925 27 CONTINUE
13926 WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13927 & 'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13928 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13929 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XPOT1/2 XMIN1/2'
13930 DO 25 I=1,MSOFT
13931 WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13932 & XMIN(1,I),XMIN(2,I)
13933 25 CONTINUE
13934 ENDIF
13935
13936 END
13937
13938*$ CREATE PHO_SELSXR.FOR
13939*COPY PHO_SELSXR
13940CDECK ID>, PHO_SELSXR
13941 SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13942 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13943C***********************************************************************
13944C
13945C select x values of soft string ends (rejection method)
13946C
13947C***********************************************************************
13948 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13949 SAVE
13950
13951 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13952
13953C input/output channels
13954 INTEGER LI,LO
13955 COMMON /POINOU/ LI,LO
13956C event debugging information
13957 INTEGER NMAXD
13958 PARAMETER (NMAXD=100)
13959 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13960 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13961 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13962 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13963C model switches and parameters
13964 CHARACTER*8 MDLNA
13965 INTEGER ISWMDL,IPAMDL
13966 DOUBLE PRECISION PARMDL
13967 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13968C data on most recent hard scattering
13969 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13970 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13971 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13972 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13973 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13974 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13975 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13976 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13977 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13978C global event kinematics and particle IDs
13979 INTEGER IFPAP,IFPAB
13980 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13981 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13982C obsolete cut-off information
13983 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13984 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13985
13986 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13987
13988 IF(IDEB(13).GE.10) THEN
13989 WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13990 WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13991 & MSOFT,XS1,XS2,XMAX1,XMAX2
13992 DO 40 I=1,MSOFT
13993 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13994 40 CONTINUE
13995 ENDIF
13996C
13997 IREJ = 0
13998C
13999 XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
14000 XMIN1 = MAX(AS/XMAX1,XMINK)
14001 XMIN2 = MAX(AS/XMAX2,XMINK)
14002C
14003 IF(MSOFT.EQ.1) THEN
14004 XSOFT1(2) = 0.D0
14005 XSOFT2(2) = 0.D0
14006 RETURN
14007 ENDIF
14008 XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
14009 & *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
14010C
14011 10 CONTINUE
14012C
14013 DO 50 I=2,MSOFT
14014 POT(1,I) = XPOT1(I)+1.D0
14015 POT(2,I) = XPOT2(I)+1.D0
14016 REVP(1,I) = 1.D0/POT(1,I)
14017 REVP(2,I) = 1.D0/POT(2,I)
14018 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14019 XLMAX = XMAX1**POT(1,I)
14020 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14021 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14022 XLMAX = XMAX2**POT(2,I)
14023 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14024 50 CONTINUE
14025C
14026 ITRY0 = 0
14027 5 CONTINUE
14028 ITRY0 = ITRY0 + 1
14029 IF(ITRY0.GE.IPAMDL(181)) THEN
14030 IF(MSOFT-MSMIN.GE.2) THEN
14031 MSOFT = MSMIN
14032 GOTO 10
14033 ENDIF
14034 GOTO 1000
14035 ENDIF
14036 XREST1 = 1.D0-XS1
14037 XREST2 = 1.D0-XS2
14038 DO 100 I=2,MSOFT
14039 ITRY1 = 0
14040
14041 20 CONTINUE
14042 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14043 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14044 XSOFT1(I) = Z1**REVP(1,I)
14045 XSOFT2(I) = Z2**REVP(2,I)
14046 ITRY1 = ITRY1+1
14047 IF(ITRY1.GE.50) GOTO 1000
14048 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14049
14050 XREST1 = XREST1-XSOFT1(I)
14051 IF(XREST1.LT.XMIN1) GOTO 5
14052 IF(XREST1.LT.XMIN(1,1)) GOTO 5
14053 XREST2 = XREST2-XSOFT2(I)
14054 IF(XREST2.LT.XMIN2) GOTO 5
14055 IF(XREST2.LT.XMIN(2,1)) GOTO 5
14056 IF(XREST1*XREST2.LT.AS) GOTO 5
14057
14058 100 CONTINUE
14059 XSOFT1(1) = XREST1
14060 XSOFT2(1) = XREST2
14061 IREJ=0
14062* XX = 1.D0
14063* DO 200 I=2,MSOFT
14064* XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
14065*200 CONTINUE
14066 XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
14067 IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
14068
14069 XS1 = 1.D0-XREST1
14070 XS2 = 1.D0-XREST2
14071 RETURN
14072
14073 1000 CONTINUE
14074 IREJ = 1
14075 IF(IDEB(13).GE.2) THEN
14076 WRITE(LO,'(1X,A,2I4)')
14077 & 'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
14078 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14079 ENDIF
14080
14081 END
14082
14083*$ CREATE PHO_SELSX2.FOR
14084*COPY PHO_SELSX2
14085CDECK ID>, PHO_SELSX2
14086 SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14087 & XS1,XS2,IREJ)
14088C***********************************************************************
14089C
14090C select x values of soft string ends using PHO_RNDBET
14091C
14092C***********************************************************************
14093 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14094 SAVE
14095
14096 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
14097
14098C input/output channels
14099 INTEGER LI,LO
14100 COMMON /POINOU/ LI,LO
14101C event debugging information
14102 INTEGER NMAXD
14103 PARAMETER (NMAXD=100)
14104 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14105 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14106 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14107 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14108C model switches and parameters
14109 CHARACTER*8 MDLNA
14110 INTEGER ISWMDL,IPAMDL
14111 DOUBLE PRECISION PARMDL
14112 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14113C data on most recent hard scattering
14114 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14115 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14116 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14117 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14118 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14119 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14120 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14121 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14122 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14123C obsolete cut-off information
14124 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14125 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14126
14127 IREJ = 0
14128
14129 IF(IDEB(32).GE.10) THEN
14130 WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14131 WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14132 & AS,XSUM1,XSUM2,XMAX1,XMAX2
14133 DO 30 I=1,2
14134 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14135 30 CONTINUE
14136 ENDIF
14137
14138 FAC1 = 1.D0-XSUM1
14139 FAC2 = 1.D0-XSUM2
14140 FAC = FAC1*FAC2
14141 GAM1 = XPOT1(1)+1.D0
14142 GAM2 = XPOT2(1)+1.D0
14143 BET1 = XPOT1(2)+1.D0
14144 BET2 = XPOT2(2)+1.D0
14145
14146 ITRY0 = 0
14147 DO 100 I=1,IPAMDL(182)
14148
14149 ITRY1 = 0
14150 10 CONTINUE
14151 X1 = PHO_RNDBET(GAM1,BET1)
14152 ITRY1 = ITRY1+1
14153 IF(ITRY1.GE.50) GOTO 1000
14154 IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14155
14156 ITRY2 = 0
14157 11 CONTINUE
14158 X2 = PHO_RNDBET(GAM2,BET2)
14159 ITRY2 = ITRY2+1
14160 IF(ITRY2.GE.50) GOTO 1000
14161 IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14162
14163 X3 = 1.D0 - X1
14164 X4 = 1.D0 - X2
14165 IF(X1*X2*FAC.GT.AS) THEN
14166 IF(X3*X4*FAC.GT.AS) THEN
14167 XS1(1) = X1*FAC1
14168 XS1(2) = X3*FAC1
14169 XS2(1) = X2*FAC2
14170 XS2(2) = X4*FAC2
14171 IF(XS1(1).GT.XMIN(1,1)) THEN
14172 IF(XS2(1).GT.XMIN(2,1)) THEN
14173 IF(XS1(2).GT.XMIN(1,2)) THEN
14174 IF(XS2(2).GT.XMIN(2,2)) THEN
14175 XSUM1 = XSUM1+XS1(2)
14176 XSUM2 = XSUM2+XS2(2)
14177 GOTO 300
14178 ENDIF
14179 ENDIF
14180 ENDIF
14181 ENDIF
14182 ENDIF
14183 ENDIF
14184 ITRY0 = ITRY0+1
14185
14186 100 CONTINUE
14187
14188 1000 CONTINUE
14189 IREJ = 1
14190 IF(IDEB(32).GE.2) THEN
14191 WRITE(LO,'(1X,A,3I4)')
14192 & 'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14193 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14194 ENDIF
14195 RETURN
14196 300 CONTINUE
14197
14198 END
14199
14200*$ CREATE PHO_SELSXS.FOR
14201*COPY PHO_SELSXS
14202CDECK ID>, PHO_SELSXS
14203 SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14204 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14205C***********************************************************************
14206C
14207C select x values of soft string ends (rescaling method)
14208C
14209C***********************************************************************
14210 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14211 SAVE
14212
14213 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14214
14215C input/output channels
14216 INTEGER LI,LO
14217 COMMON /POINOU/ LI,LO
14218C event debugging information
14219 INTEGER NMAXD
14220 PARAMETER (NMAXD=100)
14221 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14222 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14223 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14224 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14225C model switches and parameters
14226 CHARACTER*8 MDLNA
14227 INTEGER ISWMDL,IPAMDL
14228 DOUBLE PRECISION PARMDL
14229 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14230C data on most recent hard scattering
14231 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14232 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14233 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14234 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14235 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14236 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14237 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14238 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14239 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14240C obsolete cut-off information
14241 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14242 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14243
14244 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14245
14246 IREJ = 0
14247
14248 10 CONTINUE
14249
14250 IF(MSOFT.EQ.1) THEN
14251 XSOFT1(1) = 1.D0-XS1
14252 XSOFT1(2) = 0.D0
14253 XSOFT2(1) = 1.D0-XS2
14254 XSOFT2(2) = 0.D0
14255 RETURN
14256 ENDIF
14257
14258 DO 50 I=1,MSOFT
14259 POT(1,I) = XPOT1(I)+1.D0
14260 POT(2,I) = XPOT2(I)+1.D0
14261 REVP(1,I) = 1.D0/POT(1,I)
14262 REVP(2,I) = 1.D0/POT(2,I)
14263 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14264 XLMAX = XMAX1**POT(1,I)
14265 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14266 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14267 XLMAX = XMAX2**POT(2,I)
14268 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14269 50 CONTINUE
14270
14271 ITRY0 = 0
14272 5 CONTINUE
14273 ITRY0 = ITRY0 + 1
14274 IF(ITRY0.GE.IPAMDL(180)) THEN
14275 IF(MSOFT-MSMIN.GE.2) THEN
14276 MSOFT= MSMIN
14277 GOTO 10
14278 ENDIF
14279 GOTO 1000
14280 ENDIF
14281 XSUM1 = 0.D0
14282 XSUM2 = 0.D0
14283 DO 100 I=1,MSOFT
14284 ITRY1 = 0
14285 20 CONTINUE
14286 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14287 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14288 XSOFT1(I) = Z1**REVP(1,I)
14289 XSOFT2(I) = Z2**REVP(2,I)
14290 ITRY1 = ITRY1+1
14291 IF(ITRY1.GE.50) GOTO 1000
14292 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14293 XSUM1 = XSUM1+XSOFT1(I)
14294 XSUM2 = XSUM2+XSOFT2(I)
14295 100 CONTINUE
14296 FAC1 = (1.D0-XS1)/XSUM1
14297 FAC2 = (1.D0-XS2)/XSUM2
14298 DO 200 I=1,MSOFT
14299 XSOFT1(I) = XSOFT1(I)*FAC1
14300 XSOFT2(I) = XSOFT2(I)*FAC2
14301 IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14302 IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14303 IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14304 200 CONTINUE
14305
14306 XS1 = 1.D0-XSOFT1(1)
14307 XS2 = 1.D0-XSOFT2(1)
14308 RETURN
14309
14310 1000 CONTINUE
14311 IREJ = 1
14312 IF(IDEB(14).GE.2) THEN
14313 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14314 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14315 DO 300 I=1,MSOFT
14316 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14317 300 CONTINUE
14318 ENDIF
14319
14320 END
14321
14322*$ CREATE PHO_SELSXI.FOR
14323*COPY PHO_SELSXI
14324CDECK ID>, PHO_SELSXI
14325 SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14326 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14327C***********************************************************************
14328C
14329C select x values of soft string ends (sea independent from valence)
14330C
14331C***********************************************************************
14332 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14333 SAVE
14334
14335 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14336
14337C input/output channels
14338 INTEGER LI,LO
14339 COMMON /POINOU/ LI,LO
14340C event debugging information
14341 INTEGER NMAXD
14342 PARAMETER (NMAXD=100)
14343 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14344 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14345 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14346 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14347C model switches and parameters
14348 CHARACTER*8 MDLNA
14349 INTEGER ISWMDL,IPAMDL
14350 DOUBLE PRECISION PARMDL
14351 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14352C data on most recent hard scattering
14353 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14354 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14355 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14356 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14357 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14358 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14359 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14360 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14361 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14362C obsolete cut-off information
14363 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14364 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14365
14366 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14367
14368 IREJ = 0
14369
14370 10 CONTINUE
14371
14372 DO 50 I=1,MSOFT
14373 POT(1,I) = XPOT1(I)+1.D0
14374 POT(2,I) = XPOT2(I)+1.D0
14375 REVP(1,I) = 1.D0/POT(1,I)
14376 REVP(2,I) = 1.D0/POT(2,I)
14377 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14378 XLMAX = XMAX1**POT(1,I)
14379 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14380 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14381 XLMAX = XMAX2**POT(2,I)
14382 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14383 50 CONTINUE
14384
14385C selection of sea
14386 ITRY0 = 0
14387 5 CONTINUE
14388
14389 ITRY0 = ITRY0 + 1
14390 IF(ITRY0.GE.IPAMDL(183)) THEN
14391 IF(MSOFT-MSMIN.GE.2) THEN
14392 MSOFT = MSMIN
14393 GOTO 10
14394 ENDIF
14395 GOTO 1000
14396 ENDIF
14397 XSUM1 = XS1
14398 XSUM2 = XS2
14399 DO 100 I=3,MSOFT
14400 ITRY1 = 0
14401 20 CONTINUE
14402 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14403 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14404 XSOFT1(I) = Z1**REVP(1,I)
14405 XSOFT2(I) = Z2**REVP(2,I)
14406 ITRY1 = ITRY1+1
14407 IF(ITRY1.GE.50) GOTO 1000
14408 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14409 XSUM1 = XSUM1+XSOFT1(I)
14410 XSUM2 = XSUM2+XSOFT2(I)
14411 100 CONTINUE
14412
14413 IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14414 IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14415
14416C selection of valence
14417 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14418 & XSOFT1,XSOFT2,IREJ)
14419 IF(IREJ.NE.0) THEN
14420 IF(MSOFT-MSMIN.GE.2) THEN
14421 MSOFT = MSMIN
14422 GOTO 10
14423 ENDIF
14424 IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14425 & 'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14426 & XSUM1,XSUM2,XMAX1,XMAX2
14427 RETURN
14428 ENDIF
14429
14430 XS1 = 1.D0-XSOFT1(1)
14431 XS2 = 1.D0-XSOFT2(1)
14432 RETURN
14433
14434 1000 CONTINUE
14435 IREJ = 1
14436 IF(IDEB(14).GE.2) THEN
14437 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14438 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14439 DO 300 I=1,MSOFT
14440 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14441 300 CONTINUE
14442 ENDIF
14443
14444 END
14445
14446*$ CREATE PHO_SELCOL.FOR
14447*COPY PHO_SELCOL
14448CDECK ID>, PHO_SELCOL
14449 SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14450C********************************************************************
14451C
14452C color combinatorics
14453C
14454C input: ICO1,2 colors of incoming particle
14455C IMODE -2 output of initialization status
14456C -1 initialization
14457C ICINP(1) selection mode
14458C 0 QCD
14459C 1 large N_c expansion
14460C ICINP(2) max. allowed color
14461C 0 clear internal color counter
14462C 1 hadron into two colored objects
14463C 2 quark into quark gluon
14464C 3 gluon into gluon gluon
14465C 4 gluon into quark antiquark
14466C
14467C output: ICOA1,2 colors of first outgoing particle
14468C ICOB1,2 colors of second outgoing particle
14469C
14470C********************************************************************
14471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14472 SAVE
14473
14474C input/output channels
14475 INTEGER LI,LO
14476 COMMON /POINOU/ LI,LO
14477C event debugging information
14478 INTEGER NMAXD
14479 PARAMETER (NMAXD=100)
14480 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14481 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14482 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14483 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14484
14485 DATA METHOD /0/, II /0/
14486
14487 ICI1 = ICO1
14488 ICI2 = ICO2
14489 IF(METHOD.EQ.0) THEN
14490
14491 IF(IMODE.EQ.1) THEN
14492 II = II+1
14493 IF(II.GT.MAXCOL)
14494 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14495 ICOA1 = II
14496 ICOA2 = 0
14497 ICOB1 = -II
14498 ICOB2 = 0
14499 ELSE IF(IMODE.EQ.2) THEN
14500 II = II+1
14501 IF(II.GT.MAXCOL)
14502 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14503 ICOA2 = 0
14504 IF(ICI1.GT.0) THEN
14505 ICOA1 = II
14506 ICOB1 = ICI1
14507 ICOB2 = -II
14508 ELSE
14509 ICOA1 = -II
14510 ICOB1 = II
14511 ICOB2 = ICI1
14512 ENDIF
14513 ELSE IF(IMODE.EQ.3) THEN
14514 II = II+1
14515 IF(II.GT.MAXCOL)
14516 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14517 IF(DT_RNDM(DUM).GT.0.5D0) THEN
14518 ICOA1 = ICI1
14519 ICOA2 = -II
14520 ICOB1 = II
14521 ICOB2 = ICI2
14522 ELSE
14523 ICOB1 = ICI1
14524 ICOB2 = -II
14525 ICOA1 = II
14526 ICOA2 = ICI2
14527 ENDIF
14528 ELSE IF(IMODE.EQ.4) THEN
14529 ICOA1 = ICI1
14530 ICOA2 = 0
14531 ICOB1 = ICI2
14532 ICOB2 = 0
14533 ELSE IF(IMODE.EQ.0) THEN
14534 II = 0
14535 ELSE IF(IMODE.EQ.-1) THEN
14536 METHOD = ICI1
14537 MAXCOL = ICI2
14538 ELSE IF(IMODE.EQ.-2) THEN
14539 WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14540 & METHOD,MAXCOL
14541 ELSE
14542 WRITE(LO,'(1X,A,I5)')
14543 & 'PHO_SELCOL:ERROR: unsupported mode',IMODE
14544 CALL PHO_ABORT
14545 ENDIF
14546
14547 ELSE
14548 WRITE(LO,'(1X,A,I5)')
14549 & 'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14550 CALL PHO_ABORT
14551 ENDIF
14552
14553 II = ABS(II)
14554 IF(IDEB(75).GE.10) THEN
14555 WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14556 & IMODE,MAXCOL,II
14557 WRITE(LO,'(10X,A,2I5)') 'input colors',ICI1,ICI2
14558 WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14559 ENDIF
14560
14561 END
14562
14563*$ CREATE ipho_diqu.FOR
14564*COPY ipho_diqu
14565CDECK ID>, ipho_diqu
14566 INTEGER FUNCTION ipho_diqu(iq1,iq2)
14567C***********************************************************************
14568C
14569C selection of diquark number (PDG convention)
14570C
14571C***********************************************************************
14572
14573 IMPLICIT NONE
14574
14575 SAVE
14576
14577 integer iq1,iq2
14578
14579C input/output channels
14580 INTEGER LI,LO
14581 COMMON /POINOU/ LI,LO
14582C event debugging information
14583 INTEGER NMAXD
14584 PARAMETER (NMAXD=100)
14585 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14586 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14587 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14588 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14589C model switches and parameters
14590 CHARACTER*8 MDLNA
14591 INTEGER ISWMDL,IPAMDL
14592 DOUBLE PRECISION PARMDL
14593 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14594
14595C external functions
14596 double precision DT_RNDM
14597
14598C local variables
14599 integer i0,i1,i2
14600 double precision dum
14601
14602 i1 = abs(iq1)
14603 i2 = abs(iq2)
14604
14605 if(i1.eq.i2) then
14606 i0 = i1*1100+3
14607 else
14608 i0 = max(i1,i2)*1000+min(i1,i2)*100
14609 if(DT_RNDM(dum).gt.PARMDL(135)) then
14610 i0 = i0+1
14611 else
14612 i0 = i0+3
14613 endif
14614 endif
14615
14616 ipho_diqu = sign(i0,iq1)
14617
14618 END
14619
14620*$ CREATE PHO_PARREM.FOR
14621*COPY PHO_PARREM
14622CDECK ID>, PHO_PARREM
14623 SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14624C**********************************************************************
14625C
14626C selection of particle remnant flavour(s) (quark or diquark)
14627C
14628C input: INDX index of particle in /POEVT1/
14629C IOUT parton which was taken out
14630C
14631C output: IREM remnant according to valence flavours
14632C IREJ 0 flavour combination possible
14633C 1 flavour combination impossible
14634C
14635C all particle ID are given according to PDG conventions
14636C
14637C**********************************************************************
14638
14639 IMPLICIT NONE
14640
14641 SAVE
14642
14643 integer INDX,IOUT,IREM,IREJ
14644
14645C input/output channels
14646 INTEGER LI,LO
14647 COMMON /POINOU/ LI,LO
14648C event debugging information
14649 INTEGER NMAXD
14650 PARAMETER (NMAXD=100)
14651 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14652 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14653 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14654 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14655
14656C standard particle data interface
14657 INTEGER NMXHEP
14658
14659 PARAMETER (NMXHEP=4000)
14660
14661 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14662 DOUBLE PRECISION PHEP,VHEP
14663 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14664 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14665 & VHEP(4,NMXHEP)
14666C extension to standard particle data interface (PHOJET specific)
14667 INTEGER IMPART,IPHIST,ICOLOR
14668 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14669
14670C general particle data
14671 double precision xm_list,tau_list,gam_list,
14672 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14673 & xm_bb82_list,xm_bb102_list
14674 integer ich3_list,iba3_list,iq_list,
14675 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14676 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14677 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14678 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14679 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14680 & ich3_list(300),iba3_list(300),iq_list(3,300),
14681 & id_psm_list(6,6),id_vem_list(6,6),
14682 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14683
14684C external functions
14685 integer ipho_diqu
14686
14687C local variables
14688 integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14689 dimension IQUA(3),IDQ(2)
14690
14691 ID1 = IDHEP(INDX)
14692 ID2 = IMPART(INDX)
14693 IREJ = 0
14694
14695 IF(ID2.EQ.0) THEN
14696 WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14697 CALL PHO_ABORT
14698 ENDIF
14699
14700C particle with flavour mixing
14701 if(ID1.eq.22) then
14702C photon
14703 IREM = -IOUT
14704 GOTO 100
14705 else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14706C pi0, rho0, and omega
14707 IF(ABS(IOUT).LE.2) THEN
14708 IREM = -IOUT
14709 GOTO 100
14710 ELSE
14711 GOTO 150
14712 ENDIF
14713 else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14714C neutral kaons (K0,K0-bar)
14715 if(abs(IOUT).eq.1) then
14716 IREM = sign(3,-IOUT)
14717 goto 100
14718 else if(abs(IOUT).eq.3) then
14719 IREM = sign(1,-IOUT)
14720 goto 100
14721 else
14722 goto 150
14723 endif
14724 else if((ID1.eq.990).or.(ID1.eq.110)) then
14725C pomeron and reggeon
14726 IREM = -IOUT
14727 GOTO 100
14728 endif
14729
14730C ordinary hadron
14731 ID = abs(ID2)
14732 IS = sign(1,ID2)
14733 IQUA(1) = iq_list(1,ID)*IS
14734 IQUA(2) = iq_list(2,ID)*IS
14735 IQUA(3) = iq_list(3,ID)*IS
14736
14737C compare to flavour content
14738 IF(ABS(IOUT).LT.1000) THEN
14739C single quark requested
14740 IF(IQUA(1).EQ.IOUT) THEN
14741 K1 = 2
14742 K2 = 3
14743 ELSE IF(IQUA(2).EQ.IOUT) THEN
14744 K1 = 1
14745 K2 = 3
14746 ELSE IF(IQUA(3).EQ.IOUT) THEN
14747 K1 = 1
14748 K2 = 2
14749 ELSE
14750 GOTO 150
14751 ENDIF
14752 IF(IQUA(3).EQ.0) THEN
14753 IREM = IQUA(K1)
14754 ELSE
14755 IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14756 ENDIF
14757 ELSE IF(IQUA(3).NE.0) THEN
14758C diquark requested from baryon
14759 IDQ(1) = IOUT/1000
14760 IDQ(2) = (IOUT-IDQ(1)*1000)/100
14761 do i=1,2
14762 do k=1,3
14763 if(IDQ(i).eq.IQUA(k)) then
14764 IQUA(k) = 0
14765 goto 110
14766 endif
14767 enddo
14768 goto 150
14769 110 continue
14770 enddo
14771 IREM = IQUA(1)+IQUA(2)+IQUA(3)
14772 ENDIF
14773
14774 100 CONTINUE
14775C debug output
14776 IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14777 & 'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14778 & INDX,ID1,ID2,IOUT,IREM
14779 RETURN
14780
14781C rejection
14782 150 CONTINUE
14783 IREJ = 1
14784 IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14785 & 'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14786
14787 END
14788
14789*$ CREATE PHO_VALFLA.FOR
14790*COPY PHO_VALFLA
14791CDECK ID>, PHO_VALFLA
14792 SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14793C***********************************************************************
14794C
14795C selection of valence flavour decomposition of particle IPAR
14796C
14797C input: IPAR particle index in /POEVT1/
14798C -1 initialization
14799C -2 output of statistics
14800C XMASS mass of particle
14801C (important for pomeron:
14802C mass dependent flavour sampling)
14803C
14804C output: IFL1,IFL2
14805C baryon: IFL1 diquark flavour
14806C (valence flavours according to PDG conventions)
14807C
14808C***********************************************************************
14809 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14810 SAVE
14811
14812 PARAMETER ( EPS = 0.1D0,
14813 & DEPS = 1.D-15)
14814
14815C input/output channels
14816 INTEGER LI,LO
14817 COMMON /POINOU/ LI,LO
14818C event debugging information
14819 INTEGER NMAXD
14820 PARAMETER (NMAXD=100)
14821 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14822 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14823 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14824 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14825C model switches and parameters
14826 CHARACTER*8 MDLNA
14827 INTEGER ISWMDL,IPAMDL
14828 DOUBLE PRECISION PARMDL
14829 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14830
14831C standard particle data interface
14832 INTEGER NMXHEP
14833
14834 PARAMETER (NMXHEP=4000)
14835
14836 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14837 DOUBLE PRECISION PHEP,VHEP
14838 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14839 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14840 & VHEP(4,NMXHEP)
14841C extension to standard particle data interface (PHOJET specific)
14842 INTEGER IMPART,IPHIST,ICOLOR
14843 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14844
14845C general particle data
14846 double precision xm_list,tau_list,gam_list,
14847 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14848 & xm_bb82_list,xm_bb102_list
14849 integer ich3_list,iba3_list,iq_list,
14850 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14851 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14852 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14853 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14854 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14855 & ich3_list(300),iba3_list(300),iq_list(3,300),
14856 & id_psm_list(6,6),id_vem_list(6,6),
14857 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14858
14859 data ITMX / 5 /
14860
14861 IF(IPAR.GT.0) THEN
14862 K = IPAR
14863C select particle code
14864 ID1 = IDHEP(K)
14865 ID = abs(IMPART(K))
14866 IBAR = IPHO_BAR3(K,2)
14867 ITER = 0
14868
14869 10 CONTINUE
14870
14871 ifl1 = 0
14872 ifl2 = 0
14873 ITER = ITER+1
14874 if(ITER.GT.ITMX) then
14875 WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14876 & 'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14877 return
14878 endif
14879
14880C not baryon
14881 IF(IBAR.EQ.0) THEN
14882
14883C photon
14884 IF(ID1.EQ.22) THEN
14885C charge dependent flavour sampling
14886 15 CONTINUE
14887 K = INT(DT_RNDM(E1)*6.D0)+1
14888 IF(K.LE.4) THEN
14889 IFL1 = 2
14890 IFL2 = -2
14891 ELSE IF(K.EQ.5) THEN
14892 IFL1 = 1
14893 IFL2 = -1
14894 ELSE
14895 IFL1 = 3
14896 IFL2 = -3
14897 ENDIF
14898C optional strangeness suppression
14899 IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14900 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14901 K = IFL1
14902 IFL1 = IFL2
14903 IFL2 = K
14904 ENDIF
14905
14906C pomeron, reggeon
14907 ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14908 IF(ISWMDL(19).EQ.0) THEN
14909C SU(3) symmetric valences
14910 K = INT(DT_RNDM(E1)*3.D0)+1
14911 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14912 IFL1 = K
14913 ELSE
14914 IFL1 = -K
14915 ENDIF
14916 IFL2 = -IFL1
14917 ELSE IF(ISWMDL(19).EQ.1) THEN
14918C mass dependent flavour sampling
14919 EMIN = MIN(E1,E2)
14920 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14921 ELSE
14922 WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14923 & 'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14924 CALL PHO_ABORT
14925 ENDIF
14926
14927C meson with flavour mixing
14928 ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14929 K = INT(2.D0*DT_RNDM(E1))+1
14930 IFL1 = K
14931 IFL2 = -K
14932C meson (standard)
14933 ELSE
14934 K = INT(2.D0*DT_RNDM(E1))+1
14935 IFL1 = iq_list(K,ID)
14936 K = MOD(K,2) + 1
14937 IFL2 = iq_list(K,ID)
14938 if(IFL1.EQ.0) then
14939 EMIN = MIN(E1,E2)
14940 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14941 endif
14942 ENDIF
14943
14944C baryon
14945 ELSE
14946 K = INT(2.999999D0*DT_RNDM(E2))+1
14947 K1 = MOD(K,3)+1
14948 K2 = MOD(K1,3)+1
14949 IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14950 IFL2 = iq_list(K,ID)
14951 ENDIF
14952
14953C change sign for antiparticles
14954 if(ID1.lt.0) then
14955 IFL1 = -IFL1
14956 IFL2 = -IFL2
14957 endif
14958
14959************************************************************************
14960C check kinematic constraints
14961* IF((PHO_PMASS(IFL1,3).GT.E1)
14962* & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14963************************************************************************
14964
14965C debug output
14966 IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14967 & 'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14968
14969 ELSE IF(IPAR.EQ.-1) THEN
14970C initialization
14971
14972 ELSE IF(IPAR.EQ.-2) THEN
14973C output of final statistics
14974
14975 ELSE
14976 WRITE(LO,'(1X,A,I10)')
14977 & 'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14978 CALL PHO_ABORT
14979 ENDIF
14980
14981 END
14982
14983*$ CREATE PHO_REGFLA.FOR
14984*COPY PHO_REGFLA
14985CDECK ID>, PHO_REGFLA
14986 SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14987C**********************************************************************
14988C
14989C selection of reggeon flavours
14990C
14991C input: JM1,JM2 position index of mother hadrons
14992C
14993C output: IFLR1,IFLR2 valence flavours according to
14994C PDG conventions and JM1,JM2
14995C IREJ 0 reggeon possible
14996C 1 reggeon impossible
14997C
14998C**********************************************************************
14999 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15000 SAVE
15001
15002 PARAMETER ( EPS = 0.1D0,
15003 & DEPS = 1.D-15)
15004
15005C input/output channels
15006 INTEGER LI,LO
15007 COMMON /POINOU/ LI,LO
15008C event debugging information
15009 INTEGER NMAXD
15010 PARAMETER (NMAXD=100)
15011 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15012 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15013 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15014 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15015C nucleon-nucleus / nucleus-nucleus interface to DPMJET
15016 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
15017 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
15018 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
15019 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
15020
15021C standard particle data interface
15022 INTEGER NMXHEP
15023
15024 PARAMETER (NMXHEP=4000)
15025
15026 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15027 DOUBLE PRECISION PHEP,VHEP
15028 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15029 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15030 & VHEP(4,NMXHEP)
15031C extension to standard particle data interface (PHOJET specific)
15032 INTEGER IMPART,IPHIST,ICOLOR
15033 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15034
15035 IF(JM1.GT.0) THEN
15036 IREJ = 0
15037 ITER = 0
15038C available energy
15039 E1 = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
15040 & -(PHEP(1,JM1)+PHEP(1,JM2))**2
15041 & -(PHEP(2,JM1)+PHEP(2,JM2))**2
15042 & -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
15043 50 CONTINUE
15044 ITER = ITER+1
15045 IF(ITER.GT.50) THEN
15046 IREJ = 1
15047C debug output
15048 IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
15049 & 'PHO_REGFLA: rejection, no reggeon found for',
15050 & IDHEP(JM1),IDHEP(JM2),E1
15051 RETURN
15052 ENDIF
15053
15054 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
15055 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
15056 IF(IFLA1.EQ.-IFLB1) THEN
15057 IFLR1 = IFLA2
15058 IFLR2 = IFLB2
15059 ELSE IF(IFLA1.EQ.-IFLB2) THEN
15060 IFLR1 = IFLA2
15061 IFLR2 = IFLB1
15062 ELSE IF(IFLA2.EQ.-IFLB1) THEN
15063 IFLR1 = IFLA1
15064 IFLR2 = IFLB2
15065 ELSE IF(IFLA2.EQ.-IFLB2) THEN
15066 IFLR1 = IFLA1
15067 IFLR2 = IFLB1
15068 ELSE
15069C debug output
15070 IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
15071 & 'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
15072 GOTO 50
15073 ENDIF
15074C debug output
15075 IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
15076 & 'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
15077 & JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
15078 ELSE IF(JM1.EQ.-1) THEN
15079C initialization
15080 ELSE IF(JM1.EQ.-2) THEN
15081C output of statistics
15082 ELSE
15083 WRITE(LO,'(1X,A,I10)')
15084 & 'PHO_REGFLA: invalid mother particle (JM1)',JM1
15085 CALL PHO_ABORT
15086 ENDIF
15087
15088 END
15089
15090*$ CREATE PHO_SEAFLA.FOR
15091*COPY PHO_SEAFLA
15092CDECK ID>, PHO_SEAFLA
15093 SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
15094C**********************************************************************
15095C
15096C selection of sea flavour content of particle IPAR
15097C
15098C input: IPAR particle index in /POEVT1/
15099C CHMASS available invariant string mass
15100C positive mass --> use BAMJET method
15101C negative mass --> SU(3) symmetric sea according
15102C to values given in PARMDL(1-6)
15103C IPAR -1 initialization
15104C -2 output of statistics
15105C
15106C output: sea flavours according to PDG conventions
15107C
15108C**********************************************************************
15109 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15110 SAVE
15111
15112 PARAMETER ( EPS = 0.1D0,
15113 & DEPS = 1.D-15)
15114
15115C input/output channels
15116 INTEGER LI,LO
15117 COMMON /POINOU/ LI,LO
15118C event debugging information
15119 INTEGER NMAXD
15120 PARAMETER (NMAXD=100)
15121 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15122 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15123 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15124 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15125C model switches and parameters
15126 CHARACTER*8 MDLNA
15127 INTEGER ISWMDL,IPAMDL
15128 DOUBLE PRECISION PARMDL
15129 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15130C some hadron information, will be deleted in future versions
15131 INTEGER NFS
15132 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15133 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15134
15135 IF(IPAR.GT.0) THEN
15136 IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15137C constant weights for sea
15138 15 CONTINUE
15139 SUM = 0.D0
15140 DO 40 K=1,NFSEA
15141 SUM = SUM + PARMDL(K)
15142 40 CONTINUE
15143 XI = DT_RNDM(SUM)*SUM
15144 SUM = 0.D0
15145 DO 50 K=1,NFSEA
15146 SUM = SUM + PARMDL(K)
15147 IF(XI.LE.SUM) GOTO 55
15148 50 CONTINUE
15149 55 CONTINUE
15150 IF(K.GT.NFSEA) GOTO 15
15151 ELSE
15152C mass dependent flavour sampling
15153 10 CONTINUE
15154 CALL PHO_FLAUX(CHMASS,K)
15155 IF(K.GT.NFSEA) GOTO 10
15156 ENDIF
15157 IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15158 IFL1 = K
15159 IFL2 = -K
15160 IF(IDEB(46).GE.10) THEN
15161 WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15162 & IPAR,IFL1,IFL2,CHMASS
15163 ENDIF
15164 ELSE IF(IPAR.EQ.-1) THEN
15165C initialization
15166 NFSEA = NFS
15167 ELSE IF(IPAR.EQ.-2) THEN
15168C output of statistics
15169 ELSE
15170 WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15171 CALL PHO_ABORT
15172 ENDIF
15173
15174 END
15175
15176*$ CREATE PHO_FLAUX.FOR
15177*COPY PHO_FLAUX
15178CDECK ID>, PHO_FLAUX
15179 SUBROUTINE PHO_FLAUX(EQUARK,K)
15180C***********************************************************************
15181C
15182C auxiliary subroutine to select flavours
15183C
15184C********************************************************************
15185 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15186 SAVE
15187
15188 PARAMETER ( DEPS = 1.D-14 )
15189
15190C input/output channels
15191 INTEGER LI,LO
15192 COMMON /POINOU/ LI,LO
15193C event debugging information
15194 INTEGER NMAXD
15195 PARAMETER (NMAXD=100)
15196 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15197 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15198 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15199 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15200C some hadron information, will be deleted in future versions
15201 INTEGER NFS
15202 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15203 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15204
15205 DIMENSION WGHT(9)
15206
15207C calculate weights for given energy
15208 IF(EQUARK.LT.QMASS(1)) THEN
15209 IF(IDEB(16).GE.5)
15210 & WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15211 & EQUARK
15212 WGHT(1) = 0.5D0
15213 WGHT(2) = 0.5D0
15214 WGHT(3) = 0.D0
15215 WGHT(4) = 0.D0
15216 SUM = 1.D0
15217 ELSE
15218 SUM = 0.D0
15219 DO 305 K=1,NFS
15220 IF(EQUARK.GT.QMASS(K)) THEN
15221 WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15222 ELSE
15223 WGHT(K) = 0.D0
15224 ENDIF
15225 SUM = SUM + WGHT(K)
15226 305 CONTINUE
15227 ENDIF
15228C sample flavours
15229 XI = SUM*(DT_RNDM(SUM)-DEPS)
15230 K = 0
15231 SUM = 0.D0
15232 400 CONTINUE
15233 K = K+1
15234 SUM = SUM + WGHT(K)
15235 IF(XI.GT.SUM) GOTO 400
15236C debug output
15237 IF(IDEB(16).GE.20) THEN
15238 WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15239 ENDIF
15240 END
15241
15242*$ CREATE PHO_BETAF.FOR
15243*COPY PHO_BETAF
15244CDECK ID>, PHO_BETAF
15245 DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15246C********************************************************************
15247C
15248C weights of different quark flavours
15249C
15250C********************************************************************
15251 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15252 SAVE
15253
15254 AX=0.D0
15255 BETX1=BET*X1
15256 IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15257 AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15258
15259 PHO_BETAF=AX+AY
15260
15261 END
15262
15263*$ CREATE PHO_MCHECK.FOR
15264*COPY PHO_MCHECK
15265CDECK ID>, PHO_MCHECK
15266 SUBROUTINE PHO_MCHECK(J1,IREJ)
15267C********************************************************************
15268C
15269C check parton momenta for fragmentation
15270C
15271C input: J1 first string number
15272C /POEVT1/
15273C /POSTRG/
15274C
15275C output: /POEVT1/
15276C /POSTRG/
15277C IREJ 0 successful
15278C 1 failure
15279C
15280C in case of very small string mass:
15281C NNCH mass label of string
15282C 0 string
15283C -1 octett baryon / pseudo scalar meson
15284C 1 decuplett baryon / vector meson
15285C IBHAD hadron number according to CPC,
15286C string will be treated as resonance
15287C (sometimes far off mass shell)
15288C
15289C constant WIDTH ( 0.01GeV ) determines range of acceptance
15290C
15291C********************************************************************
15292 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15293 SAVE
15294
15295 PARAMETER ( WIDTH = 0.01D0,
15296 & DEPS = 1.D-15 )
15297
15298C input/output channels
15299 INTEGER LI,LO
15300 COMMON /POINOU/ LI,LO
15301C event debugging information
15302 INTEGER NMAXD
15303 PARAMETER (NMAXD=100)
15304 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15305 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15306 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15307 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15308C model switches and parameters
15309 CHARACTER*8 MDLNA
15310 INTEGER ISWMDL,IPAMDL
15311 DOUBLE PRECISION PARMDL
15312 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15313
15314C standard particle data interface
15315 INTEGER NMXHEP
15316
15317 PARAMETER (NMXHEP=4000)
15318
15319 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15320 DOUBLE PRECISION PHEP,VHEP
15321 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15322 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15323 & VHEP(4,NMXHEP)
15324C extension to standard particle data interface (PHOJET specific)
15325 INTEGER IMPART,IPHIST,ICOLOR
15326 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15327
15328C color string configurations including collapsed strings and hadrons
15329 INTEGER MSTR
15330 PARAMETER (MSTR=500)
15331 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15332 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15333 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15334 & NNCH(MSTR),IBHAD(MSTR),ISTR
15335C internal rejection counters
15336 INTEGER NMXJ
15337 PARAMETER (NMXJ=60)
15338 CHARACTER*10 REJTIT
15339 INTEGER IFAIL
15340 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15341
15342 IREJ = 0
15343C quark antiquark jet
15344 STRM = PHEP(5,NPOS(1,J1))
15345 IF(NCODE(J1).EQ.3) THEN
15346 CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15347 & AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15348 IF(IDEB(18).GE.5)
15349 & WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15350 & 'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15351 & J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15352 IF(STRM.LT.AMPS) THEN
15353 IREJ = 1
15354 IFAIL(20) = IFAIL(20) + 1
15355 RETURN
15356 ELSE IF(STRM.LT.AMPS2) THEN
15357 IF(STRM.LT.(AMVE-WIDTH)) THEN
15358 NNCH(J1) = -1
15359 IBHAD(J1) = IPS
15360 ELSE
15361 NNCH(J1) = 1
15362 IBHAD(J1) = IVE
15363 ENDIF
15364 ELSE
15365 NNCH(J1) = 0
15366 IBHAD(J1) = 0
15367 ENDIF
15368C quark diquark or v.s. jet
15369 ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15370 CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15371 & AM8,AM82,AM10,AM102,I8,I10)
15372 IF(IDEB(18).GE.5)
15373 & WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15374 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15375 & J1,STRM,AM8,AM82,AM10,AM102
15376 IF(STRM.LT.AM8) THEN
15377 IREJ = 1
15378 IFAIL(19) = IFAIL(19) + 1
15379 RETURN
15380 ELSE IF(STRM.LT.AM82) THEN
15381 IF(STRM.LT.(AM10-WIDTH)) THEN
15382 NNCH(J1) = -1
15383 IBHAD(J1) = I8
15384 ELSE
15385 NNCH(J1) = 1
15386 IBHAD(J1) = I10
15387 ENDIF
15388 ELSE
15389 NNCH(J1) = 0
15390 IBHAD(J1) = 0
15391 ENDIF
15392C diquark a-diquark string
15393 ELSE IF(NCODE(J1).EQ.5) THEN
15394 CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15395 & AM82,AM102)
15396 IF(IDEB(18).GE.5)
15397 & WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15398 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15399 & J1,STRM,AM82,AM102
15400 IF(STRM.LT.AM82) THEN
15401 IREJ = 1
15402 IFAIL(19) = IFAIL(19) + 1
15403 RETURN
15404 ELSE
15405 NNCH(J1) = 0
15406 IBHAD(J1) = 0
15407 ENDIF
15408 ELSE IF(NCODE(J1).LT.0) THEN
15409 RETURN
15410 ELSE
15411 WRITE(LO,'(/,1X,2A,2I8)') 'PHO_MCHECK: ',
15412 & 'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15413 CALL PHO_ABORT
15414 ENDIF
15415 END
15416
15417*$ CREATE PHO_POMCOR.FOR
15418*COPY PHO_POMCOR
15419CDECK ID>, PHO_POMCOR
15420 SUBROUTINE PHO_POMCOR(IREJ)
15421C********************************************************************
15422C
15423C join quarks to gluons in case of too small masses
15424C
15425C input: /POEVT1/
15426C /POSTRG/
15427C IREJ -1 initialization
15428C -2 output of statistics
15429C
15430C output: /POEVT1/
15431C /POSTRG/
15432C IREJ 0 successful
15433C 1 failure
15434C
15435C
15436C********************************************************************
15437 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15438 SAVE
15439
15440 PARAMETER ( EPS = 1.D-10 )
15441
15442C input/output channels
15443 INTEGER LI,LO
15444 COMMON /POINOU/ LI,LO
15445C event debugging information
15446 INTEGER NMAXD
15447 PARAMETER (NMAXD=100)
15448 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15449 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15450 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15451 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15452C model switches and parameters
15453 CHARACTER*8 MDLNA
15454 INTEGER ISWMDL,IPAMDL
15455 DOUBLE PRECISION PARMDL
15456 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15457
15458C standard particle data interface
15459 INTEGER NMXHEP
15460
15461 PARAMETER (NMXHEP=4000)
15462
15463 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15464 DOUBLE PRECISION PHEP,VHEP
15465 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15466 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15467 & VHEP(4,NMXHEP)
15468C extension to standard particle data interface (PHOJET specific)
15469 INTEGER IMPART,IPHIST,ICOLOR
15470 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15471
15472C color string configurations including collapsed strings and hadrons
15473 INTEGER MSTR
15474 PARAMETER (MSTR=500)
15475 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15476 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15477 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15478 & NNCH(MSTR),IBHAD(MSTR),ISTR
15479
15480 DIMENSION PJ(4)
15481
15482 IF(IREJ.EQ.-1) THEN
15483 ICTOT = 0
15484 ICCOR = 0
15485 RETURN
15486 ELSE IF(IREJ.EQ.-2) THEN
15487 WRITE(LO,'(/1X,A,2I8)')
15488 & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15489 RETURN
15490 ENDIF
15491C
15492 IREJ = 0
15493C
15494 NITER = 100
15495 ITER = 0
15496 ICTOT = ICTOT+ISTR
15497 IF(ISWMDL(25).LE.0) RETURN
15498C debug string entries
15499 IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15500C
15501 50 CONTINUE
15502 ITER = ITER+1
15503 IF(ITER.GE.NITER) THEN
15504 IREJ = 1
15505 IF(IDEB(83).GE.2) THEN
15506 WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15507 IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15508 ENDIF
15509 RETURN
15510 ENDIF
15511C
15512C check mass limits
15513 ISTRO = ISTR
15514 DO 100 I=1,ISTRO
15515 IF(NCODE(I).LT.0) GOTO 99
15516 J1 = NPOS(1,I)
15517 NRPOM = IPHIST(2,J1)
15518 IF(NRPOM.GE.100) GOTO 99
15519 CMASS0 = PHEP(5,J1)
15520C get masses
15521 IF(NCODE(I).EQ.3) THEN
15522 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15523 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15524 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15525 & AM1,AM2,AM3,AM4,IP1,IP2)
15526 ELSE IF(NCODE(I).EQ.5) THEN
15527 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15528 & AM1,AM2)
15529 AM3 = 0.D0
15530 AM4 = 0.D0
15531 IP1 = 0
15532 IP2 = 0
15533 ELSE IF(NCODE(I).EQ.7) THEN
15534 GOTO 99
15535 ELSE IF(NCODE(I).LT.0) THEN
15536 GOTO 99
15537 ELSE
15538 WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15539 & J1,NCODE(I)
15540 CALL PHO_ABORT
15541 ENDIF
15542 IF(IDEB(83).GE.5)
15543 & WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15544 & 'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15545 & I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15546C select masses to correct
15547 IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15548 DO 200 K=1,ISTRO
15549 IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15550 J2 = NPOS(1,K)
15551C join quarks to gluon
15552 IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15553C flavour check
15554 IFL1 = 0
15555 IFL2 = 0
15556 PROB1 = 0.D0
15557 PROB2 = 0.D0
15558 KK1 = NPOS(2,I)
15559 KK2 = NPOS(2,K)
15560 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15561 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15562 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15563 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15564 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15565 IFL1 = ABS(IDHEP(KK1))
15566 IF(IFL1.GT.2) THEN
15567 PROB1 = 0.1D0/MAX(CMASS,EPS)
15568 ELSE
15569 PROB1 = 0.9D0/MAX(CMASS,EPS)
15570 ENDIF
15571 ENDIF
15572 KK1 = ABS(NPOS(3,I))
15573 KK2 = ABS(NPOS(3,K))
15574 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15575 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15576 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15577 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15578 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15579 IFL2 = ABS(IDHEP(KK1))
15580 IF(IFL2.GT.2) THEN
15581 PROB2 = 0.1D0/MAX(CMASS,EPS)
15582 ELSE
15583 PROB2 = 0.9D0/MAX(CMASS,EPS)
15584 ENDIF
15585 ENDIF
15586 IF(IFL1+IFL2.EQ.0) GOTO 99
15587C fusion possible
15588 ICCOR = ICCOR+1
15589 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15590 JJ = 2
15591 JE = 3
15592 ELSE
15593 JJ = 3
15594 JE = 2
15595 ENDIF
15596 KK1 = ABS(NPOS(JJ,I))
15597 KK2 = ABS(NPOS(JJ,K))
15598 I1 = ABS(NPOS(JE,I))
15599 I2 = KK1
15600 IS = SIGN(1,I2-I1)
15601 I2 = I2 - IS
15602 K1 = KK2
15603 K2 = ABS(NPOS(JE,K))
15604 KS = SIGN(1,K2-K1)
15605 K1 = K1 + KS
15606 IP1 = NHEP+1
15607C copy mother partons of string I
15608 DO 300 II=I1,I2,IS
15609 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15610 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15611 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15612 300 CONTINUE
15613C register gluon
15614 DO 350 II=1,4
15615 PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15616 350 CONTINUE
15617 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15618 & I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15619C copy mother partons of string K
15620 DO 400 II=K1,K2,KS
15621 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15622 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15623 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15624 400 CONTINUE
15625C create new string entry
15626 DO 450 II=1,4
15627 PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15628 450 CONTINUE
15629 IP2 = IPOS
15630 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15631 & PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15632 & ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15633C delete string K in /POSTRG/
15634 NCODE(K) = -999
15635C update string I in /POSTRG/
15636 NPOS(1,I) = IPOS
15637 NPOS(2,I) = IP1
15638 NPOS(3,I) = -IP2
15639C calculate new CPC string codes
15640 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15641 & IPAR2(I),IPAR3(I),IPAR4(I))
15642 GOTO 99
15643 ENDIF
15644 ENDIF
15645 200 CONTINUE
15646 ENDIF
15647 99 CONTINUE
15648 100 CONTINUE
15649 IF(IDEB(83).GE.20) THEN
15650 WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15651 IF(IDEB(83).GE.22) THEN
15652 CALL PHO_PRSTRG
15653 CALL PHO_PREVNT(0)
15654 ENDIF
15655 ENDIF
15656
15657 END
15658
15659*$ CREATE PHO_MASCOR.FOR
15660*COPY PHO_MASCOR
15661CDECK ID>, PHO_MASCOR
15662 SUBROUTINE PHO_MASCOR(IREJ)
15663C********************************************************************
15664C
15665C check and adjust parton momenta for fragmentation
15666C
15667C input: /POEVT1/
15668C /POSTRG/
15669C IREJ -1 initialization
15670C -2 output of statistics
15671C
15672C output: /POEVT1/
15673C /POSTRG/
15674C IREJ 0 successful
15675C 1 failure
15676C
15677C in case of very small string mass:
15678C - direct manipulation of /POEVT1/ and /POEVT2/
15679C - string will be deleted from /POSTRG/ (label -99)
15680C
15681C********************************************************************
15682 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15683 SAVE
15684
15685 PARAMETER ( EPS = 1.D-10,
15686 & EMIN = 0.3D0,
15687 & DEPS = 1.D-15)
15688
15689C input/output channels
15690 INTEGER LI,LO
15691 COMMON /POINOU/ LI,LO
15692C event debugging information
15693 INTEGER NMAXD
15694 PARAMETER (NMAXD=100)
15695 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15696 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15697 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15698 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15699C internal rejection counters
15700 INTEGER NMXJ
15701 PARAMETER (NMXJ=60)
15702 CHARACTER*10 REJTIT
15703 INTEGER IFAIL
15704 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15705C model switches and parameters
15706 CHARACTER*8 MDLNA
15707 INTEGER ISWMDL,IPAMDL
15708 DOUBLE PRECISION PARMDL
15709 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15710
15711C standard particle data interface
15712 INTEGER NMXHEP
15713
15714 PARAMETER (NMXHEP=4000)
15715
15716 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15717 DOUBLE PRECISION PHEP,VHEP
15718 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15719 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15720 & VHEP(4,NMXHEP)
15721C extension to standard particle data interface (PHOJET specific)
15722 INTEGER IMPART,IPHIST,ICOLOR
15723 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15724
15725C color string configurations including collapsed strings and hadrons
15726 INTEGER MSTR
15727 PARAMETER (MSTR=500)
15728 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15729 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15730 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15731 & NNCH(MSTR),IBHAD(MSTR),ISTR
15732
15733 DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15734
15735 IF(IREJ.EQ.-1) THEN
15736 ICTOT = 0
15737 ICCOR = 0
15738 RETURN
15739 ELSE IF(IREJ.EQ.-2) THEN
15740 WRITE(LO,'(/1X,A,2I8/)')
15741 & 'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15742 RETURN
15743 ENDIF
15744
15745 IREJ = 0
15746 NITER = 100
15747 ITER = 0
15748 ICTOT = ICTOT+ISTR
15749 IF(ISWMDL(7).EQ.-1) RETURN
15750C debug /POSTRG/
15751 IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15752
15753 ITOUCH = 0
15754 50 CONTINUE
15755 ITER = ITER+1
15756 IF(ITER.GE.NITER) THEN
15757 IREJ = 1
15758 IF(IDEB(42).GE.2) THEN
15759 WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15760 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15761 ENDIF
15762 RETURN
15763 ENDIF
15764
15765C check mass limits
15766 IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15767 IM1 = 1
15768 IM2 = ISTR
15769 IST = 1
15770 ELSE
15771 IM1 = ISTR
15772 IM2 = 1
15773 IST = -1
15774 ENDIF
15775 DO 100 I=IM1,IM2,IST
15776 J1 = NPOS(1,I)
15777 CMASS0 = PHEP(5,J1)
15778C get masses
15779 IF(NCODE(I).EQ.3) THEN
15780 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15781 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15782 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15783 & AM1,AM2,AM3,AM4,IP1,IP2)
15784 ELSE IF(NCODE(I).EQ.5) THEN
15785 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15786 & AM1,AM2)
15787 AM3 = 0.D0
15788 AM4 = 0.D0
15789 IP1 = 0
15790 IP2 = 0
15791 ELSE IF(NCODE(I).EQ.7) THEN
15792 AM1 = 0.15D0
15793 AM2 = 0.3D0
15794 AM3 = 0.765D0
15795 AM4 = 1.5D0
15796*??????????????????????????????????
15797 IP1 = 23
15798 IP2 = 33
15799*??????????????????????????????????
15800 ELSE IF(NCODE(I).LT.0) THEN
15801 GOTO 90
15802 ELSE
15803 WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15804 & J1,NCODE(I)
15805 CALL PHO_ABORT
15806 ENDIF
15807 IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15808 & 'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15809 & I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15810C select masses to correct
15811 IBHAD(I) = 0
15812 NNCH(I) = 0
15813C correction needed?
15814C no resonances for diquark-antidiquark and gluon-gluon strings
15815 IF(NCODE(I).EQ.5) THEN
15816 IF(CMASS0.LT.1.3D0*AM1) THEN
15817 IF(ISWMDL(7).LE.2) THEN
15818 IBHAD(I) = 90
15819 NNCH(I) = -1
15820 CHMASS = AM1*1.3D0
15821 ELSE
15822 IREJ = 1
15823 RETURN
15824 ENDIF
15825 ENDIF
15826 ELSE
15827 INEED = 0
15828C resonances possible
15829 IF(ISWMDL(7).EQ.0) THEN
15830 IF(CMASS0.LT.AM1*0.99D0) THEN
15831 IBHAD(I) = IP1
15832 NNCH(I) = -1
15833 CHMASS = AM1
15834 INEED = 1
15835 ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15836 DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15837 DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15838 IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15839 IBHAD(I) = IP1
15840 NNCH(I) = -1
15841 CHMASS = AM1
15842 ELSE
15843 IBHAD(I) = IP2
15844 NNCH(I) = 1
15845 CHMASS = AM3
15846 ENDIF
15847 ENDIF
15848 ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15849 IF(CMASS0.LT.AM1*0.99) THEN
15850 IBHAD(I) = IP1
15851 NNCH(I) = -1
15852 CHMASS = AM1
15853 INEED = 1
15854 ENDIF
15855 ELSE IF(ISWMDL(7).EQ.3) THEN
15856 IF(CMASS0.LT.AM1) THEN
15857 IREJ = 1
15858 RETURN
15859 ENDIF
15860 ELSE
15861 WRITE(LO,'(/1X,A,I5)')
15862 & 'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15863 CALL PHO_ABORT
15864 ENDIF
15865 ENDIF
15866C
15867C correction necessary?
15868 IF(IBHAD(I).NE.0) THEN
15869C find largest invar. mass
15870 IPOS = 0
15871 CMASS1 = -1.D0
15872 DO 200 J2=NHEP,3,-1
15873
15874 IF(ABS(ISTHEP(J2)).EQ.1) THEN
15875 IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15876 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15877 & 'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15878 CALL PHO_PREVNT(0)
15879 ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15880 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15881 & -(PHEP(1,J1)+PHEP(1,J2))**2
15882 & -(PHEP(2,J1)+PHEP(2,J2))**2
15883 & -(PHEP(3,J1)+PHEP(3,J2))**2
15884 IF(CMASS2.GT.CMASS1) THEN
15885 IPOS=J2
15886 CMASS1=CMASS2
15887 ENDIF
15888 ENDIF
15889 ENDIF
15890
15891 200 CONTINUE
15892 J2 = IPOS
15893 IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15894 IF(INEED.EQ.1) THEN
15895 IREJ = 1
15896 RETURN
15897 ELSE
15898 IBHAD(I) = 0
15899 NNCH(I) = 0
15900 GOTO 90
15901 ENDIF
15902 ENDIF
15903 ISTA = ISTHEP(J1)
15904 ISTB = ISTHEP(J2)
15905 CMASS1 = SQRT(CMASS1)
15906 CMASS2 = PHEP(5,J2)
15907 IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15908 IREJ = 1
15909 IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15910 & CHMASS,CMASS2,PC1,PC2,IREJ)
15911 IF(IREJ.NE.0) THEN
15912 IFAIL(24) = IFAIL(24)+1
15913 IF(IDEB(42).GE.2) THEN
15914 WRITE(LO,'(1X,A,2I4)')
15915 & 'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15916 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15917 ENDIF
15918 IREJ = 1
15919 RETURN
15920 ENDIF
15921C momentum transfer
15922 DO 210 II=1,4
15923 PTR(II) = PHEP(II,J2)-PC2(II)
15924 210 CONTINUE
15925 IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15926 & 'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15927C copy parents of strings
15928C register partons belonging to first string
15929 IF(IDHEP(J1).EQ.90) THEN
15930 K1 = JMOHEP(1,J1)
15931 K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15932 ESUM = 0.D0
15933 DO 500 II=K1,K2
15934 ESUM = ESUM+PHEP(4,II)
15935 500 CONTINUE
15936 IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15937 DO 600 II=K1,K2
15938 FAC = PHEP(4,II)/ESUM
15939 DO 650 K=1,4
15940 P1(K) = PHEP(K,II)+FAC*PTR(K)
15941 650 CONTINUE
15942 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15943 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15944 & ICOLOR(2,II),IPOS,1)
15945 600 CONTINUE
15946 K1A = IPOS+K1-K2
15947 IF(JMOHEP(2,J1).GT.0) THEN
15948 II = JMOHEP(2,J1)
15949 FAC = PHEP(4,II)/ESUM
15950 DO 675 K=1,4
15951 P1(K) = PHEP(K,II)+FAC*PTR(K)
15952 675 CONTINUE
15953 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15954 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15955 & ICOLOR(2,II),IPOS,1)
15956 ENDIF
15957 K2A = -IPOS
15958 ELSE
15959 K1A = J1
15960 K2A = J2
15961 ENDIF
15962C register partons belonging to second string
15963 IF(IDHEP(J2).EQ.90) THEN
15964 CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15965 K1 = JMOHEP(1,J2)
15966 K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15967 ESUM = 0.D0
15968 DO 300 II=K1,K2
15969 ESUM = ESUM+PHEP(4,II)
15970 300 CONTINUE
15971 IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15972 DO 400 II=K1,K2
15973**sr 28.12.2006 fix adopted from FLUKA
15974C FAC = PHEP(4,II)/ESUM
15975 IF (ABS(ESUM).GT.0.D0) THEN
15976 FAC = PHEP(4,II)/ESUM
15977 ELSE
15978 FAC = 1.0D0
15979 ENDIF
15980**
15981 IF(IREJL.EQ.0) THEN
15982 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15983 P1(4) = P1(4)+FAC*DELE
15984 ELSE
15985 DO 450 K=1,4
15986 P1(K) = PHEP(K,II)-FAC*PTR(K)
15987 450 CONTINUE
15988 ENDIF
15989 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15990 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15991 & ICOLOR(2,II),IPOS,1)
15992 400 CONTINUE
15993 K1B = IPOS+K1-K2
15994 IF(JMOHEP(2,J2).GT.0) THEN
15995 II = JMOHEP(2,J2)
15996 FAC = PHEP(4,II)/ESUM
15997 IF(IREJL.EQ.0) THEN
15998 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15999 P1(4) = P1(4)+FAC*DELE
16000 ELSE
16001 DO 475 K=1,4
16002 P1(K) = PHEP(K,II)-FAC*PTR(K)
16003 475 CONTINUE
16004 ENDIF
16005 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
16006 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
16007 & ICOLOR(2,II),IPOS,1)
16008 ENDIF
16009 K2B = -IPOS
16010 ELSE
16011 K1B = J1
16012 K2B = J2
16013 ENDIF
16014C register first string/collapsed to hadron
16015 IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
16016 IF(NCODE(I).NE.5) THEN
16017 CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
16018 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
16019C label string as collapsed to hadron/resonance
16020 NCODE(I) = -99
16021 IDHEP(J1) = 92
16022 ELSE
16023 CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
16024 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
16025 IDHEP(J1) = 91
16026 ENDIF
16027 NPOS(1,I) = IPOS
16028 NPOS(2,I) = K1A
16029 NPOS(3,I) = K2A
16030 ELSE
16031 CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
16032 & PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
16033 & ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
16034 IF(IDHEP(J1).EQ.90) THEN
16035 NPOS(1,IPHIST(1,J1)) = IPOS
16036 NPOS(2,IPHIST(1,J1)) = K1A
16037 NPOS(3,IPHIST(1,J1)) = K2A
16038C label string as collapsed to resonance-string
16039 IDHEP(J1) = 91
16040 ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
16041 IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
16042 ENDIF
16043 ENDIF
16044C register second string/hadron/parton
16045 CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
16046 & PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
16047 & ICOLOR(2,J2),IPOS,1)
16048 IF(IDHEP(J2).EQ.90) THEN
16049 NPOS(1,IPHIST(1,J2))=IPOS
16050 NPOS(2,IPHIST(1,J2))=K1B
16051 NPOS(3,IPHIST(1,J2))=K2B
16052C label string touched by momentum transfer
16053 IDHEP(J2) = 91
16054 ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
16055 IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
16056 ENDIF
16057 ICCOR = ICCOR+1
16058 ITOUCH = ITOUCH+1
16059C consistency checks
16060 IF(IDEB(42).GE.5) THEN
16061 CALL PHO_CHECK(-1,IDEV)
16062 IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
16063 ENDIF
16064C jump to next iteration
16065 GOTO 50
16066 ENDIF
16067 90 CONTINUE
16068 100 CONTINUE
16069C debug output
16070 IF(IDEB(42).GE.15) THEN
16071 IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
16072 WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
16073 CALL PHO_PREVNT(1)
16074 ENDIF
16075 ENDIF
16076 END
16077
16078*$ CREATE PHO_PARCOR.FOR
16079*COPY PHO_PARCOR
16080CDECK ID>, PHO_PARCOR
16081 SUBROUTINE PHO_PARCOR(MODE,IREJ)
16082C********************************************************************
16083C
16084C conversion of string partons (using JETSET masses)
16085C
16086C input: MODE >0 position index of corresponding string
16087C -1 initialization
16088C -2 output of statistics
16089C
16090C output: /POSTRG/
16091C IREJ 1 combination of strings impossible
16092C 0 successful combination
16093C
16094C********************************************************************
16095 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16096 SAVE
16097
16098 PARAMETER ( DELM = 0.005D0,
16099 & DEPS = 1.D-15,
16100 & EPS = 1.D-5)
16101
16102C input/output channels
16103 INTEGER LI,LO
16104 COMMON /POINOU/ LI,LO
16105C event debugging information
16106 INTEGER NMAXD
16107 PARAMETER (NMAXD=100)
16108 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16109 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16110 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16111 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16112C internal rejection counters
16113 INTEGER NMXJ
16114 PARAMETER (NMXJ=60)
16115 CHARACTER*10 REJTIT
16116 INTEGER IFAIL
16117 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16118C model switches and parameters
16119 CHARACTER*8 MDLNA
16120 INTEGER ISWMDL,IPAMDL
16121 DOUBLE PRECISION PARMDL
16122 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16123
16124C standard particle data interface
16125 INTEGER NMXHEP
16126
16127 PARAMETER (NMXHEP=4000)
16128
16129 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16130 DOUBLE PRECISION PHEP,VHEP
16131 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16132 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16133 & VHEP(4,NMXHEP)
16134C extension to standard particle data interface (PHOJET specific)
16135 INTEGER IMPART,IPHIST,ICOLOR
16136 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16137
16138C color string configurations including collapsed strings and hadrons
16139 INTEGER MSTR
16140 PARAMETER (MSTR=500)
16141 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16142 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16143 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16144 & NNCH(MSTR),IBHAD(MSTR),ISTR
16145
16146 DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16147 & PL(4,100),XMP(100),XML(100)
16148
16149 DOUBLE PRECISION PYMASS
16150
16151 IREJ = 0
16152 IMODE = MODE
16153C
16154 IF(IMODE.GT.0) THEN
16155 ICH = 0
16156 I1 = JMOHEP(1,IMODE)
16157 I2 = ABS(JMOHEP(2,IMODE))
16158C copy to local field
16159 L = 0
16160 DO 100 I=I1,I2
16161 L = L+1
16162 DO 200 K=1,4
16163 PL(K,L) = PHEP(K,I)
16164 200 CONTINUE
16165 XMP(L) = PHEP(5,I)
16166
16167 XML(L) = PYMASS(IDHEP(I))
16168
16169 100 CONTINUE
16170 IPAR = L
16171 XMC = PHEP(5,IMODE)
16172 IF(IDEB(82).GE.20) THEN
16173 WRITE(LO,'(1X,A,I7,2I4)')
16174 & 'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16175 & KEVENT,IMODE,L
16176 DO 150 I=1,L
16177 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16178 & XMP(I),XML(I)
16179 150 CONTINUE
16180 ENDIF
16181C
16182C two parton configurations
16183C -----------------------------------------
16184 IF(IPAR.EQ.2) THEN
16185 XM1 = XML(1)
16186 XM2 = XML(2)
16187 IF((XM1+XM2).GE.XMC) THEN
16188 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16189 & 'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16190 & IMODE,XM1,XM2,XMC
16191 GOTO 990
16192 ENDIF
16193C conversion possible
16194 CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16195 IF(IREJ.NE.0) THEN
16196 IFAIL(36) = IFAIL(36)+1
16197 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16198 & 'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16199 & KEVENT,IMODE,XMC
16200 GOTO 990
16201 ENDIF
16202 ICH = 1
16203 DO 115 K=1,4
16204 PL(K,1) = PP1(K)
16205 PL(K,2) = PP2(K)
16206 XMP(1) = XM1
16207 XMP(2) = XM2
16208 115 CONTINUE
16209C
16210C multi parton configurations
16211C ---------------------------------
16212 ELSE
16213C
16214C random selection of string side to start with
16215 IF(DT_RNDM(XMC).LT.0.5D0) THEN
16216 K1 = 1
16217 K2 = IPAR
16218 KS = 1
16219 ELSE
16220 K1 = IPAR
16221 K2 = 1
16222 KS = -1
16223 ENDIF
16224 ITER = 0
16225C
16226 300 CONTINUE
16227 IF(ITER.LT.4) THEN
16228 KK = K1
16229 K1 = K2
16230 K2 = KK
16231 KS = -KS
16232 ELSE
16233 GOTO 990
16234 ENDIF
16235 ITER = ITER+1
16236C select method
16237 IF(ITER.GT.2) GOTO 230
16238
16239C conversion according to color flow method
16240 IFAI = 0
16241 DO 210 II=K1,K2-KS,KS
16242 DO 215 IK=II+KS,K2,KS
16243 XM1 = XML(II)
16244 XM2 = XML(IK)
16245* IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16246* & 'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16247 IF((ABS(XM1-XMP(II)).GT.DELM)
16248 & .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16249 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16250 IF(IREJ.NE.0) THEN
16251 IFAIL(36) = IFAIL(36)+1
16252 IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16253 & 'PHO_PARCOR: ',
16254 & 'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16255 & KEVENT,IMODE,II,IK
16256 IREJ = 0
16257 ELSE
16258 ICH = ICH+1
16259 DO 220 KK=1,4
16260 PL(KK,II) = PP1(KK)
16261 PL(KK,IK) = PP2(KK)
16262 220 CONTINUE
16263 XMP(II) = XM1
16264 XMP(IK) = XM2
16265 GOTO 219
16266 ENDIF
16267 ELSE
16268 GOTO 219
16269 ENDIF
16270 215 CONTINUE
16271 IFAI = II
16272 219 CONTINUE
16273 210 CONTINUE
16274 IF(IFAI.NE.0) GOTO 300
16275 GOTO 950
16276C
16277 230 CONTINUE
16278C
16279C conversion according to remainder method
16280 DO 350 I=K1,K2,KS
16281 XM1 = XML(I)
16282 IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16283 ICH = ICH+1
16284 IFAI = I
16285C conversion necessary
16286 DO 400 K=1,4
16287 PB1(K) = PL(K,I)
16288 PB2(K) = PHEP(K,IMODE)-PB1(K)
16289 400 CONTINUE
16290 XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16291 IF(XM2.LT.0.D0) THEN
16292 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16293 & 'PHO_PARCOR: ',
16294 & 'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16295 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16296 GOTO 300
16297 ENDIF
16298 XM2 = SQRT(XM2)
16299 IF((XM1+XM2).GE.XMC) THEN
16300 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16301 & 'PHO_PARCOR: ',
16302 & 'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16303 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16304 GOTO 300
16305 ENDIF
16306C conversion possible
16307 CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16308 IF(IREJ.NE.0) THEN
16309 IFAIL(36) = IFAIL(36)+1
16310 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16311 & 'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16312 & ITER,IMODE,I
16313 GOTO 300
16314 ENDIF
16315C calculate Lorentz transformation
16316 CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16317 IF(IREJ.NE.0) THEN
16318 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16319 & 'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16320 & ITER,IMODE,I
16321 GOTO 300
16322 ENDIF
16323 IFAI = 0
16324C transform remaining partons
16325 DO 450 L=K1,K2,KS
16326 IF(L.NE.I) THEN
16327 CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16328 DO 500 K=1,4
16329 PL(K,L) = PP2(K)
16330 500 CONTINUE
16331 ELSE
16332 DO 550 K=1,4
16333 PL(K,L) = PP1(K)
16334 550 CONTINUE
16335 ENDIF
16336 450 CONTINUE
16337 XMP(I) = XM1
16338 ENDIF
16339 350 CONTINUE
16340 ENDIF
16341
16342C register transformed partons
16343 950 CONTINUE
16344 IREJ = 0
16345 IF(ICH.NE.0) THEN
16346 IP1 = NHEP+1
16347 L = 0
16348 DO 700 I=I1,I2
16349 L= L+1
16350 CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16351 & PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16352 & ICOLOR(2,I),IPOS,1)
16353 700 CONTINUE
16354 IP2 = IPOS
16355C register string
16356 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16357 & PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16358 & IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16359C update /POSTRG/
16360 I = IPHIST(1,IMODE)
16361 NPOS(1,I) = IPOS
16362 NPOS(2,I) = IP1
16363 NPOS(3,I) = -IP2
16364 ENDIF
16365C debug output
16366 IF(IDEB(82).GE.20) THEN
16367 WRITE(LO,'(1X,A,I7,2I4)')
16368 & 'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16369 & KEVENT,IMODE,L
16370 DO 850 I=1,L
16371 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16372 & XMP(I),XML(I)
16373 850 CONTINUE
16374 WRITE(LO,'(1X,A,2I5)')
16375 & 'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16376 ENDIF
16377 RETURN
16378C rejection
16379 990 CONTINUE
16380 IREJ = 1
16381 IF(IDEB(82).GE.3) THEN
16382 WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16383 & 'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16384 & IFAI,IPAR,IMODE,XMC
16385 IF(IDEB(82).GE.5) THEN
16386 WRITE(LO,'(1X,A,I7,2I4)')
16387 & 'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16388 & KEVENT,IMODE,IPAR
16389 DO 155 I=1,IPAR
16390 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16391 & XMP(I),XML(I)
16392 155 CONTINUE
16393 ENDIF
16394 ENDIF
16395 RETURN
16396
16397 ELSE IF(IMODE.EQ.-1) THEN
16398C initialization
16399 RETURN
16400
16401 ELSE IF(IMODE.EQ.-2) THEN
16402C final output
16403 RETURN
16404 ENDIF
16405 END
16406
16407*$ CREATE PHO_STRING.FOR
16408*COPY PHO_STRING
16409CDECK ID>, PHO_STRING
16410 SUBROUTINE PHO_STRING(IMODE,IREJ)
16411C********************************************************************
16412C
16413C calculation of string combinatorics, Lorentz boosts and
16414C particle codes
16415C
16416C - splitting of gluons
16417C - strings will be built up from pairs of partons
16418C according to their color labels
16419C with IDHEP(..) = -1
16420C - there can be other particles between to string partons
16421C (these will be unchanged by string construction)
16422C - string mass fine correction
16423C
16424C input: IMODE 1 complete string processing
16425C -1 initialization
16426C -2 output of statistics
16427C
16428C output: /POSTRG/
16429C IREJ 1 combination of strings impossible
16430C 0 successful combination
16431C 50 rejection due to user cutoffs
16432C
16433C********************************************************************
16434 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16435 SAVE
16436
16437 PARAMETER ( DEPS = 1.D-15,
16438 & EPS = 1.D-5 )
16439
16440C input/output channels
16441 INTEGER LI,LO
16442 COMMON /POINOU/ LI,LO
16443C event debugging information
16444 INTEGER NMAXD
16445 PARAMETER (NMAXD=100)
16446 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16447 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16448 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16449 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16450C general process information
16451 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16452 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16453C internal rejection counters
16454 INTEGER NMXJ
16455 PARAMETER (NMXJ=60)
16456 CHARACTER*10 REJTIT
16457 INTEGER IFAIL
16458 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16459C model switches and parameters
16460 CHARACTER*8 MDLNA
16461 INTEGER ISWMDL,IPAMDL
16462 DOUBLE PRECISION PARMDL
16463 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16464C hard cross sections and MC selection weights
16465 INTEGER Max_pro_2
16466 PARAMETER ( Max_pro_2 = 16 )
16467 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16468 & MH_acc_1,MH_acc_2
16469 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16470 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16471 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16472 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16473 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16474 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16475
16476C standard particle data interface
16477 INTEGER NMXHEP
16478
16479 PARAMETER (NMXHEP=4000)
16480
16481 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16482 DOUBLE PRECISION PHEP,VHEP
16483 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16484 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16485 & VHEP(4,NMXHEP)
16486C extension to standard particle data interface (PHOJET specific)
16487 INTEGER IMPART,IPHIST,ICOLOR
16488 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16489
16490C color string configurations including collapsed strings and hadrons
16491 INTEGER MSTR
16492 PARAMETER (MSTR=500)
16493 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16494 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16495 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16496 & NNCH(MSTR),IBHAD(MSTR),ISTR
16497C table of particle indices for recursive PHOJET calls
16498 INTEGER MAXIPX
16499 PARAMETER ( MAXIPX = 100 )
16500 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16501 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16502 & IPOIX1,IPOIX2,IPOIX3
16503C some constants
16504 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16505 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16506 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16507
16508 IREJ = 0
16509 IF(IMODE.EQ.-1) THEN
16510 CALL PHO_POMCOR(-1)
16511 CALL PHO_MASCOR(-1)
16512 CALL PHO_PARCOR(-1,IREJ)
16513
16514 RETURN
16515 ELSE IF(IMODE.EQ.-2) THEN
16516 CALL PHO_POMCOR(-2)
16517 CALL PHO_MASCOR(-2)
16518 CALL PHO_PARCOR(-2,IREJ)
16519
16520 RETURN
16521 ENDIF
16522
16523C generate enhanced graphs
16524 IF(IPOIX2.GT.0) THEN
16525 200 CONTINUE
16526 I1 = MAX(1,IPOIX1)
16527 I2 = IPOIX2
16528 IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16529 KSPOMS = KSPOM-1
16530 KSREGS = KSREG
16531 KHPOMS = KHPOM
16532 KHDIRS = KHDIR
16533 IDDFS1 = IDIFR1
16534 IDDFS2 = IDIFR2
16535 IDDPOS = IDDPOM
16536 DO 110 I=I1,I2
16537 IPOIX3 = I
16538 KSPOM = 0
16539 KSREG = 0
16540 KHPOM = 0
16541 KHDIR = 0
16542 IF(IPORES(I).EQ.8) THEN
16543 KSPOM = 2
16544 LSPOM = 2
16545 LHPOM = 0
16546 LSREG = 0
16547 LHDIR = 0
16548 IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16549 CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16550 & LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16551 IF(IREJ.NE.0) THEN
16552 IF(IDEB(4).GE.2) THEN
16553 WRITE(LO,'(/1X,A,I5)')
16554 & 'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16555 CALL PHO_PREVNT(-1)
16556 ENDIF
16557 RETURN
16558 ENDIF
16559 KSPOM = KSPOMS+LSPOM
16560 KSREG = KSREGS+LSREG
16561 KHPOM = KHPOMS+LHPOM
16562 KHDIR = KHDIRS+LHDIR
16563 ELSE IF(IPORES(I).EQ.4) THEN
16564 ITEMP = ISWMDL(17)
16565 ISWMDL(17) = 0
16566 CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16567 ISWMDL(17) = ITEMP
16568 IF(IREJ.NE.0) THEN
16569 IF(IDEB(4).GE.2) THEN
16570 WRITE(LO,'(/1X,A,I5)')
16571 & 'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16572 CALL PHO_PREVNT(-1)
16573 ENDIF
16574 RETURN
16575 ENDIF
16576 KSDPO = KSDPO+1
16577 KSPOM = KSPOMS+KSPOM
16578 KSREG = KSREGS+KSREG
16579 KHPOM = KHPOMS+KHPOM
16580 KHDIR = KHDIRS+KHDIR
16581 ELSE
16582 IDIF1 = 1
16583 IDIF2 = 1
16584 IF(IPORES(I).EQ.5) THEN
16585 IDIF2 = 0
16586 KSTRG = KSTRG+1
16587 ELSE IF(IPORES(I).EQ.6) THEN
16588 IDIF1 = 0
16589 KSTRG = KSTRG+1
16590 ELSE
16591 KSLOO = KSLOO+1
16592 ENDIF
16593 ITEMP = ISWMDL(16)
16594 ISWMDL(16) = 0
16595 SPROB = 1.D0
16596 CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16597 & 0,MSOFT,MHARD,IREJ)
16598 ISWMDL(16) = ITEMP
16599 IF(IREJ.NE.0) THEN
16600 IF(IDEB(4).GE.2) THEN
16601 WRITE(LO,'(/1X,A,I5)')
16602 & 'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16603 CALL PHO_PREVNT(-1)
16604 ENDIF
16605 RETURN
16606 ENDIF
16607 KSPOM = KSPOMS+KSPOM
16608 KSREG = KSREGS+KSREG
16609 KHPOM = KHPOMS+KHPOM
16610 KHDIR = KHDIRS+KHDIR
16611 ENDIF
16612 IDIFR1 = IDDFS1
16613 IDIFR2 = IDDFS2
16614 IDDPOM = IDDPOS
16615 110 CONTINUE
16616 IF(IPOIX2.GT.I2) THEN
16617 IPOIX1 = I2+1
16618 GOTO 200
16619 ENDIF
16620 ENDIF
16621
16622C optional: split gluons to q-qbar pairs
16623 IF(ISWMDL(9).GT.0) THEN
16624 NHEPO = NHEP
16625 DO 30 I=3,NHEPO
16626 IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16627 ICG1=ICOLOR(1,I)
16628 ICG2=ICOLOR(2,I)
16629 IQ1 = 0
16630 IQ2 = 0
16631 DO 40 K=3,NHEPO
16632 IF(ICOLOR(1,K).EQ.-ICG1) THEN
16633 IQ1 = K
16634 IF(IQ1*IQ2.NE.0) GOTO 45
16635 ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16636 IQ2 = K
16637 IF(IQ1*IQ2.NE.0) GOTO 45
16638 ENDIF
16639 40 CONTINUE
16640 WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16641 & 'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16642 CALL PHO_ABORT
16643 45 CONTINUE
16644 CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16645 IF(IREJ.NE.0) THEN
16646 IF(IDEB(19).GE.5) THEN
16647 WRITE(LO,'(/,1X,A)')
16648 & 'PHO_STRING: no gluon splitting possible'
16649 CALL PHO_PREVNT(0)
16650 ENDIF
16651 RETURN
16652 ENDIF
16653 ENDIF
16654 30 CONTINUE
16655 ENDIF
16656
16657C construct strings and write entries sorted by strings
16658
16659 ISTR = ISTR+1
16660 NHEPO = NHEP
16661 DO 50 I=3,NHEPO
16662
16663 IF(ISTR.GT.MSTR) THEN
16664 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16665 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16666 CALL PHO_PREVNT(0)
16667 IREJ = 1
16668 RETURN
16669 ENDIF
16670
16671 IF(ISTHEP(I).EQ.1) THEN
16672C hadrons / resonances / clusters
16673 NPOS(1,ISTR) = I
16674 NPOS(2,ISTR) = 0
16675 NPOS(3,ISTR) = 0
16676 NPOS(4,ISTR) = abs(IPHIST(2,I))
16677 NCODE(ISTR) = -99
16678 IPHIST(1,I) = ISTR
16679 ISTR = ISTR+1
16680 ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16681C quark /diquark terminated strings
16682 ICOL1 = -ICOLOR(1,I)
16683 P1 = PHEP(1,I)
16684 P2 = PHEP(2,I)
16685 P3 = PHEP(3,I)
16686 P4 = PHEP(4,I)
16687 ICH1 = IPHO_CHR3(I,2)
16688 IBA1 = IPHO_BAR3(I,2)
16689 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16690 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16691 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16692 JM1 = IPOS
16693
16694 NRPOM = 0
16695 65 CONTINUE
16696 DO 55 K=3,NHEPO
16697 IF(ISTHEP(K).EQ.-1)THEN
16698 IF(IDHEP(K).EQ.21) THEN
16699 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16700 ICOL1 = -ICOLOR(2,K)
16701 GOTO 60
16702 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16703 ICOL1 = -ICOLOR(1,K)
16704 GOTO 60
16705 ENDIF
16706 ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16707 ICOL1 = 0
16708 GOTO 60
16709 ENDIF
16710 ENDIF
16711 55 CONTINUE
16712 WRITE(LO,'(/1X,A,I5)')
16713 & 'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16714 CALL PHO_ABORT
16715 60 CONTINUE
16716 P1 = P1+PHEP(1,K)
16717 P2 = P2+PHEP(2,K)
16718 P3 = P3+PHEP(3,K)
16719 P4 = P4+PHEP(4,K)
16720 NRPOM = MAX(NRPOM,IPHIST(1,K))
16721 ICH1 = ICH1+IPHO_CHR3(K,2)
16722 IBA1 = IBA1+IPHO_BAR3(K,2)
16723 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16724 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16725 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16726C further parton involved?
16727 IF(ICOL1.NE.0) GOTO 65
16728 JM2 = IPOS
16729C register string
16730 IGEN = IPHIST(2,K)
16731 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16732 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16733C store additional string information
16734 NPOS(1,ISTR) = IPOS
16735 NPOS(2,ISTR) = JM1
16736 NPOS(3,ISTR) = -JM2
16737 NPOS(4,ISTR) = abs(IPHIST(2,K))
16738C calculate CPC string codes
16739 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16740 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16741 ISTR = ISTR+1
16742 ENDIF
16743 50 CONTINUE
16744
16745 DO 150 I=3,NHEPO
16746
16747 IF(ISTR.GT.MSTR) THEN
16748 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16749 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16750 CALL PHO_PREVNT(0)
16751 IREJ = 1
16752 RETURN
16753 ENDIF
16754
16755 IF(ISTHEP(I).EQ.-1) THEN
16756C gluon loop-strings
16757 ICOL1 = -ICOLOR(1,I)
16758 P1 = PHEP(1,I)
16759 P2 = PHEP(2,I)
16760 P3 = PHEP(3,I)
16761 P4 = PHEP(4,I)
16762 IBA1 = 0
16763 ICH1 = 0
16764 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16765 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16766 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16767 JM1 = IPOS
16768C
16769 NRPOM = 0
16770 165 CONTINUE
16771 IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16772 DO 155 K=I,NHEPO
16773 IF(ISTHEP(K).EQ.-1)THEN
16774 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16775 ICOL1 = -ICOLOR(2,K)
16776 GOTO 160
16777 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16778 ICOL1 = -ICOLOR(1,K)
16779 GOTO 160
16780 ENDIF
16781 ENDIF
16782 155 CONTINUE
16783 WRITE(LO,'(/1X,A,I5)')
16784 & 'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16785 CALL PHO_ABORT
16786 160 CONTINUE
16787 P1 = P1+PHEP(1,K)
16788 P2 = P2+PHEP(2,K)
16789 P3 = P3+PHEP(3,K)
16790 P4 = P4+PHEP(4,K)
16791 NRPOM = MAX(NRPOM,IPHIST(1,K))
16792 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16793 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16794 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16795C further parton involved?
16796 IF(ICOL1.NE.0) GOTO 165
16797 170 CONTINUE
16798 JM2 = IPOS
16799C register string
16800 IGEN = IPHIST(2,K)
16801 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16802 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16803C store additional string information
16804 NPOS(1,ISTR) = IPOS
16805 NPOS(2,ISTR) = JM1
16806 NPOS(3,ISTR) = -JM2
16807 NPOS(4,ISTR) = abs(IPHIST(2,K))
16808C calculate CPC string codes
16809 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16810 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16811 ISTR = ISTR+1
16812 ENDIF
16813 150 CONTINUE
16814
16815 ISTR = ISTR-1
16816
16817 IF(IDEB(19).GE.17) THEN
16818 WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16819 CALL PHO_PREVNT(0)
16820 ENDIF
16821
16822C pomeron corrections
16823 CALL PHO_POMCOR(IREJ)
16824 IF(IREJ.NE.0) THEN
16825 IFAIL(38) = IFAIL(38)+1
16826 IF(IDEB(19).GE.3) THEN
16827 WRITE(LO,'(1X,A,I6)')
16828 & 'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16829 CALL PHO_PREVNT(-1)
16830 ENDIF
16831 RETURN
16832 ENDIF
16833
16834C string mass corrections
16835 CALL PHO_MASCOR(IREJ)
16836 IF(IREJ.NE.0) THEN
16837 IFAIL(34) = IFAIL(34)+1
16838 IF(IDEB(19).GE.3) THEN
16839 WRITE(LO,'(1X,A,I6)')
16840 & 'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16841 CALL PHO_PREVNT(-1)
16842 ENDIF
16843 RETURN
16844 ENDIF
16845
16846C parton mass corrections
16847 DO 100 I=1,ISTR
16848 IF(NCODE(I).GE.0) THEN
16849 CALL PHO_PARCOR(NPOS(1,I),IREJ)
16850 IF(IREJ.NE.0) THEN
16851 IFAIL(35) = IFAIL(35)+1
16852 IF(IDEB(19).GE.3) THEN
16853 WRITE(LO,'(1X,A,I6)')
16854 & 'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16855 CALL PHO_PREVNT(-1)
16856 ENDIF
16857 RETURN
16858 ENDIF
16859 ENDIF
16860 100 CONTINUE
16861
16862C statistics of hard processes
16863 DO 550 I=3,NHEP
16864 IF(ISTHEP(I).EQ.25) THEN
16865 K = IMPART(I)
16866 II = IDHEP(I)
16867 MH_acc_2(K,II) = MH_acc_2(K,II)+1
16868 ENDIF
16869 550 CONTINUE
16870
16871C debug: write out strings
16872 IF(IDEB(19).GE.5) THEN
16873 IF(IDEB(19).GE.10)
16874 & CALL PHO_CHECK(1,IDEV)
16875 IF(IDEB(19).GE.15) THEN
16876 CALL PHO_PREVNT(0)
16877 ELSE
16878 CALL PHO_PRSTRG
16879 ENDIF
16880 ENDIF
16881
16882 END
16883
16884*$ CREATE PHO_STRFRA.FOR
16885*COPY PHO_STRFRA
16886CDECK ID>, PHO_STRFRA
16887 SUBROUTINE PHO_STRFRA(IREJ)
16888C********************************************************************
16889C
16890C do all fragmentation of strings
16891C
16892C output: IREJ 0 successful
16893C 1 rejection
16894C 50 rejection due to user cutoffs
16895C
16896C********************************************************************
16897
16898 IMPLICIT NONE
16899
16900 SAVE
16901
16902C input/output channels
16903 INTEGER LI,LO
16904 COMMON /POINOU/ LI,LO
16905C some constants
16906 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16907 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16908 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16909C event debugging information
16910 INTEGER NMAXD
16911 PARAMETER (NMAXD=100)
16912 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16913 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16914 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16915 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16916C general process information
16917 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16918 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16919C model switches and parameters
16920 CHARACTER*8 MDLNA
16921 INTEGER ISWMDL,IPAMDL
16922 DOUBLE PRECISION PARMDL
16923 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16924C global event kinematics and particle IDs
16925 INTEGER IFPAP,IFPAB
16926 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16927 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16928
16929C standard particle data interface
16930 INTEGER NMXHEP
16931
16932 PARAMETER (NMXHEP=4000)
16933
16934 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16935 DOUBLE PRECISION PHEP,VHEP
16936 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16937 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16938 & VHEP(4,NMXHEP)
16939C extension to standard particle data interface (PHOJET specific)
16940 INTEGER IMPART,IPHIST,ICOLOR
16941 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16942
16943C color string configurations including collapsed strings and hadrons
16944 INTEGER MSTR
16945 PARAMETER (MSTR=500)
16946 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16947 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16948 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16949 & NNCH(MSTR),IBHAD(MSTR),ISTR
16950
16951 INTEGER IREJ
16952
16953 DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16954
16955 INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16956 & IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16957
16958 integer indx(500),indx_max
16959
16960 DOUBLE PRECISION DT_RNDM
16961 INTEGER ipho_pdg2id
16962 EXTERNAL DT_RNDM,ipho_pdg2id
16963
16964 DOUBLE PRECISION PYP,RQLUN
16965 INTEGER PYK
16966
16967 INTEGER MSTU,MSTJ
16968 DOUBLE PRECISION PARU,PARJ
16969 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16970
16971 INTEGER N,NPAD,K
16972 DOUBLE PRECISION P,V
16973 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16974
16975 DIMENSION IJOIN(100)
16976
16977 IREJ = 0
16978 IF(ABS(ISWMDL(6)).GT.3) THEN
16979 WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16980 & 'invalid value of ISWMDL(6)',ISWMDL(6)
16981 CALL PHO_ABORT
16982 ENDIF
16983
16984C popcorn suppression
16985 IF(PARMDL(134).GT.0.D0) THEN
16986 IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16987 MSTJ(12) = 2
16988 ELSE
16989 MSTJ(12) = 1
16990 ENDIF
16991 ENDIF
16992
16993C copy partons to fragmentation code JETSET
16994 IP = 0
16995 IP_old = 1
16996
16997 DO 300 J=1,ISTR
16998
16999C select partons with common production process
17000 IGEN = NPOS(4,J)
17001 if(IGEN.lt.0) goto 299
17002
17003 indx_max = 0
17004 DO 400 I=J,ISTR
17005 if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
17006
17007C write final particles/resonances to JETSET
17008 IF(NCODE(I).EQ.-99) THEN
17009 II = NPOS(1,I)
17010 IP = IP+1
17011 P(IP,1) = PHEP(1,II)
17012 P(IP,2) = PHEP(2,II)
17013 P(IP,3) = PHEP(3,II)
17014 P(IP,4) = PHEP(4,II)
17015 P(IP,5) = PHEP(5,II)
17016 K(IP,1) = 1
17017 K(IP,2) = IDHEP(II)
17018 K(IP,3) = 0
17019 K(IP,4) = 0
17020 K(IP,5) = 0
17021 IPHIST(2,II) = IP
17022
17023 if(indx_max.eq.500) then
17024 WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
17025 & 'no space left in index vector (indx,Kevent)',
17026 & indx_max,KEVENT
17027 IREJ = 1
17028 return
17029 endif
17030
17031 indx_max = indx_max+1
17032 indx(indx_max) = II
17033C write partons to JETSET
17034 ELSE IF(NCODE(I).GE.0) THEN
17035 K1 = JMOHEP(1,NPOS(1,I))
17036 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
17037 IJ = 0
17038 DO II=K1,K2
17039 IP = IP+1
17040 P(IP,1) = PHEP(1,II)
17041 P(IP,2) = PHEP(2,II)
17042 P(IP,3) = PHEP(3,II)
17043 P(IP,4) = PHEP(4,II)
17044 P(IP,5) = PHEP(5,II)
17045 K(IP,1) = 1
17046 K(IP,2) = IDHEP(II)
17047 K(IP,3) = 0
17048 K(IP,4) = 0
17049 K(IP,5) = 0
17050 IPHIST(2,II) = IP
17051 IJ = IJ+1
17052 IJOIN(IJ) = IP
17053 indx_max = indx_max+1
17054 indx(indx_max) = II
17055
17056 ENDDO
17057 II = JMOHEP(2,NPOS(1,I))
17058 IF((II.GT.0).AND.(II.NE.K1)) THEN
17059 IP = IP+1
17060 P(IP,1) = PHEP(1,II)
17061 P(IP,2) = PHEP(2,II)
17062 P(IP,3) = PHEP(3,II)
17063 P(IP,4) = PHEP(4,II)
17064 P(IP,5) = PHEP(5,II)
17065 K(IP,1) = 1
17066 K(IP,2) = IDHEP(II)
17067 K(IP,3) = 0
17068 K(IP,4) = 0
17069 K(IP,5) = 0
17070 IPHIST(2,II) = IP
17071 IJ = IJ+1
17072 IJOIN(IJ) = IP
17073 indx_max = indx_max+1
17074 indx(indx_max) = II
17075
17076 ENDIF
17077 N = IP
17078C connect partons to strings
17079
17080 CALL PYJOIN(IJ,IJOIN)
17081
17082 ENDIF
17083
17084 NPOS(4,I) = -NPOS(4,I)
17085 endif
17086 400 continue
17087
17088C set Lund counter
17089 N = IP
17090 if(IP.eq.0) goto 299
17091
17092C hard final state evolution
17093 IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
17094 ISH = 0
17095 do 125 k1=1,indx_max
17096 I = indx(k1)
17097 IF(IPHIST(1,I).LE.-100) THEN
17098 ISH = ISH+1
17099 IJOIN(ISH) = I
17100 ENDIF
17101 125 continue
17102 IF(ISH.GE.2) THEN
17103 DO 130 K1=1,ISH
17104 IF(IJOIN(K1).EQ.0) GOTO 130
17105 I = IJOIN(K1)
17106 IF((IPAMDL(102).EQ.1)
17107 & .AND.(IPHIST(1,I).NE.-100)) GOTO 130
17108 DO 135 K2=K1+1,ISH
17109 IF(IJOIN(K2).EQ.0) GOTO 135
17110 II = IJOIN(K2)
17111 IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
17112 PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
17113 PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
17114 RQLUN = MIN(PT1,PT2)
17115
17116 IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
17117 & 'PHO_STRFRA: PYSHOW called',I,II,RQLUN
17118 CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
17119
17120 IJOIN(K1) = 0
17121 IJOIN(K2) = 0
17122 GOTO 130
17123 ENDIF
17124 135 CONTINUE
17125 130 CONTINUE
17126 ENDIF
17127 ENDIF
17128
17129C fragment parton / hadron configuration (hadronization & decay)
17130
17131 IF(ISWMDL(6).NE.0) THEN
17132 II = MSTU(21)
17133 MSTU(21) = 1
17134
17135 CALL PYEXEC
17136
17137 MSTU(21) = II
17138C Lund warning?
17139 if(MSTU(28).ne.0) then
17140 IF(IDEB(22).GE.10) THEN
17141 WRITE(LO,'(1X,A,I12,I3)')
17142 & 'PHO_STRFRA:(1) Lund code warning (EV/code)',
17143 & KEVENT,MSTU(28)
17144 CALL PHO_PREVNT(2)
17145 ENDIF
17146 endif
17147C event accepted?
17148 IF(MSTU(24).NE.0) THEN
17149 IF(IDEB(22).GE.2) THEN
17150 WRITE(LO,'(1X,A,I12,I3)')
17151 & 'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
17152 & KEVENT,MSTU(24)
17153 CALL PHO_PREVNT(2)
17154 ENDIF
17155 IREJ = 1
17156 RETURN
17157 ENDIF
17158 ENDIF
17159
17160 IP = N
17161C change particle status in JETSET to avoid internal adjustments
17162 do k1=IP_old,IP
17163 K(k1,1) = K(k1,1)+1000
17164 enddo
17165 IP_old = IP+1
17166
17167 299 continue
17168 300 CONTINUE
17169
17170C restore original JETSET particle status codes
17171 do i=1,N
17172 K(i,1) = K(i,1)-1000
17173 enddo
17174
17175* IF(IDEB(22).GE.25) THEN
17176* WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17177* & 'particle/string system before fragmentation'
17178* CALL PHO_PREVNT(2)
17179* ENDIF
17180
17181C copy hadrons back to POEVT1 / POEVT2
17182
17183 IF(IP.GT.0) THEN
17184 NHEP1 = NHEP+1
17185
17186 NLINES = PYK(0,1)
17187
17188C copy hadrons back with full history information
17189 IF(IPAMDL(178).EQ.1) THEN
17190 DO 155 II=1,ISTR
17191 IF(NCODE(II).GE.0) THEN
17192 K1 = IPHIST(2,NPOS(2,II))
17193 K2 = IPHIST(2,-NPOS(3,II))
17194 ELSE IF(NCODE(II).EQ.-99) THEN
17195 K1 = IPHIST(2,NPOS(1,II))
17196 K2 = K1
17197 ELSE
17198 GOTO 149
17199 ENDIF
17200 IFOUND = 0
17201 DO 160 J=1,NLINES
17202
17203 IF(PYK(J,7).EQ.1) THEN
17204 IPMOTH = PYK(J,15)
17205
17206 IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17207
17208 IBAM = ipho_pdg2id(PYK(J,8))
17209
17210 IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17211 IF(IDEB(22).GE.2) THEN
17212 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17213 & 'LUND interface (1) rejection'
17214 CALL PHO_PREVNT(2)
17215 ENDIF
17216 IREJ = 1
17217 RETURN
17218 ENDIF
17219 IFOUND = IFOUND+1
17220
17221 PX = PYP(J,1)
17222 PY = PYP(J,2)
17223 PZ = PYP(J,3)
17224 HE = PYP(J,4)
17225 XMB = PYP(J,5)**2
17226
17227C register parton/hadron
17228 IS = 1
17229 IF(IBAM.EQ.0) THEN
17230 IF(ISWMDL(6).EQ.0) THEN
17231 IS = -1
17232 ELSE
17233 IF(IDEB(22).GE.2) THEN
17234 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17235 & 'LUND interface (2) rejection'
17236 CALL PHO_PREVNT(2)
17237 ENDIF
17238 IREJ = 1
17239 RETURN
17240 ENDIF
17241 ENDIF
17242
17243 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17244 & PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17245
17246 ISTHEP(IPOS) = 1
17247 ENDIF
17248 ENDIF
17249 160 CONTINUE
17250 IF(IFOUND.EQ.0) THEN
17251 IF(IDEB(2).GE.2) THEN
17252 WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17253 & 'no particles found for string (EVE,ISTR):',KEVENT,II
17254 ENDIF
17255 ISTHEP(NPOS(1,II)) = 2
17256 ENDIF
17257 149 CONTINUE
17258 155 CONTINUE
17259 ELSE
17260C copy hadrons back without history information
17261 JDAHEP(1,1) = NHEP1
17262 JDAHEP(1,2) = NHEP1
17263 DO 170 J=1,NLINES
17264
17265 IF(PYK(J,7).EQ.1) THEN
17266 IBAM = ipho_pdg2id(PYK(J,8))
17267
17268 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17269 IF(IDEB(22).GE.2) THEN
17270 WRITE(LO,'(/1X,A)')
17271 & 'PHO_STRFRA: LUND interface (3) rejection'
17272 CALL PHO_PREVNT(2)
17273 ENDIF
17274 IREJ = 1
17275 RETURN
17276 ENDIF
17277
17278 PX = PYP(J,1)
17279 PY = PYP(J,2)
17280 PZ = PYP(J,3)
17281 HE = PYP(J,4)
17282 XMB = PYP(J,5)**2
17283
17284C register parton/hadron
17285 IS = 1
17286 IF(IBAM.EQ.0) THEN
17287 IF(ISWMDL(6).EQ.0) THEN
17288 IS = -1
17289 ELSE
17290 IF(IDEB(22).GE.2) THEN
17291 WRITE(LO,'(/1X,A)')
17292 & 'PHO_STRFRA: LUND interface (4) rejection'
17293 CALL PHO_PREVNT(2)
17294 ENDIF
17295 IREJ = 1
17296 RETURN
17297 ENDIF
17298 ENDIF
17299
17300 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17301 & HE,J,0,0,0,IPOS,1)
17302
17303 ISTHEP(IPOS) = 1
17304 ENDIF
17305 170 CONTINUE
17306 DO 180 II=1,ISTR
17307 IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17308 & ISTHEP(NPOS(1,II)) = 2
17309 180 CONTINUE
17310 ENDIF
17311 ENDIF
17312
17313C debug event status
17314 IF(IDEB(22).GE.15) THEN
17315 WRITE(LO,'(//1X,A)')
17316 & 'PHO_STRFRA: particle system after fragmentation'
17317 CALL PHO_PREVNT(2)
17318 ENDIF
17319
17320 END
17321
17322*$ CREATE PHO_EVEINI.FOR
17323*COPY PHO_EVEINI
17324CDECK ID>, PHO_EVEINI
17325 SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17326C********************************************************************
17327C
17328C prepare /POEVT1/ for new event
17329C
17330C first subroutine called for each event
17331C
17332C input: P1(4) particle 1
17333C P2(4) particle 2
17334C IMODE 0 general initialization
17335C 1 initialization of particles and kinematics
17336C 2 initialization after internal rejection
17337C
17338C output: IP1,IP2 index of interacting particles
17339C
17340C********************************************************************
17341 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17342 SAVE
17343
17344 DIMENSION P1(4),P2(4)
17345
17346 PARAMETER ( EPS = 1.D-5,
17347 & DEPS = 1.D-15 )
17348
17349C input/output channels
17350 INTEGER LI,LO
17351 COMMON /POINOU/ LI,LO
17352C event debugging information
17353 INTEGER NMAXD
17354 PARAMETER (NMAXD=100)
17355 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17356 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17357 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17358 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17359C model switches and parameters
17360 CHARACTER*8 MDLNA
17361 INTEGER ISWMDL,IPAMDL
17362 DOUBLE PRECISION PARMDL
17363 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17364C general process information
17365 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17366 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17367C gamma-lepton or gamma-hadron vertex information
17368 INTEGER IGHEL,IDPSRC,IDBSRC
17369 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17370 & RADSRC,AMSRC,GAMSRC
17371 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17372 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17373 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17374C global event kinematics and particle IDs
17375 INTEGER IFPAP,IFPAB
17376 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17377 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17378C energy-interpolation table
17379 INTEGER IEETA2
17380 PARAMETER ( IEETA2 = 20 )
17381 INTEGER ISIMAX
17382 DOUBLE PRECISION SIGTAB,SIGECM
17383 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17384C cross sections
17385 INTEGER IPFIL,IFAFIL,IFBFIL
17386 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17387 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17388 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17389 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17390 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17391 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17392 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17393 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17394 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17395 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17396 & IPFIL,IFAFIL,IFBFIL
17397C color string configurations including collapsed strings and hadrons
17398 INTEGER MSTR
17399 PARAMETER (MSTR=500)
17400 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17401 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17402 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17403 & NNCH(MSTR),IBHAD(MSTR),ISTR
17404
17405C standard particle data interface
17406 INTEGER NMXHEP
17407
17408 PARAMETER (NMXHEP=4000)
17409
17410 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17411 DOUBLE PRECISION PHEP,VHEP
17412 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17413 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17414 & VHEP(4,NMXHEP)
17415C extension to standard particle data interface (PHOJET specific)
17416 INTEGER IMPART,IPHIST,ICOLOR
17417 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17418
17419C table of particle indices for recursive PHOJET calls
17420 INTEGER MAXIPX
17421 PARAMETER ( MAXIPX = 100 )
17422 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17423 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17424 & IPOIX1,IPOIX2,IPOIX3
17425C event weights and generated cross section
17426 INTEGER IPOWGC,ISWCUT,IVWGHT
17427 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17428 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17429 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17430
17431 DIMENSION IM(2)
17432
17433C reset debug variables
17434 KSPOM = 0
17435 KHPOM = 0
17436 KSREG = 0
17437 KHDIR = 0
17438 KSTRG = 0
17439 KHTRG = 0
17440 KSLOO = 0
17441 KHLOO = 0
17442 KSDPO = 0
17443 KSOFT = 0
17444 KHARD = 0
17445C
17446 IDNODF = 0
17447 IDIFR1 = 0
17448 IDIFR2 = 0
17449 IDDPOM = 0
17450 ISTR = 0
17451 IPOIX1 = 0
17452 IF(ISWMDL(14).GT.0) IPOIX1 = 1
17453 IPOIX2 = 0
17454 IPOIX3 = 0
17455C reset /POEVT1/ and /POEVT2/
17456 CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17457 & 0,0,0,0,IPOS,0)
17458 CALL PHO_SELCOL(0,0,0,0,0,0,0)
17459 DO 15 I=0,10
17460 IPOWGC(I) = 0
17461 15 CONTINUE
17462
17463C initialization of particle kinematics
17464
17465C lepton-photon/hadron-photon vertex and initial particles
17466 IM(1) = 0
17467 IM(2) = 0
17468 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17469 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17470 & PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17471 ELSE
17472 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17473 & P1(4),0,0,0,0,IP1,1)
17474 ENDIF
17475 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17476 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17477 & PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17478 ELSE
17479 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17480 & P2(4),0,0,0,0,IP2,1)
17481 ENDIF
17482 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17483 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17484 & PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17485 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17486 & P1(4),0,0,0,0,IP1,1)
17487 ENDIF
17488 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17489 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17490 & PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17491 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17492 & P2(4),0,0,0,0,IP2,1)
17493 ENDIF
17494 NEVHEP = KACCEP
17495
17496 IF(IMODE.LE.1) THEN
17497C CMS energy
17498 ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17499 & -(P1(3)+P2(3))**2)
17500* CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17501 PMASS(1) = PHEP(5,IP1)
17502 PVIRT(1) = 0.D0
17503 IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17504 PMASS(2) = PHEP(5,IP2)
17505 PVIRT(2) = 0.D0
17506 IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17507 ENDIF
17508
17509C cross section calculations
17510
17511 IF(IMODE.NE.1) THEN
17512 IP = 1
17513 CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17514 & ECM,PVIRT(1),PVIRT(2))
17515 ENDIF
17516
17517 IF(IMODE.LE.0) THEN
17518C effective cross section
17519 SIGGEN(3) = 0.D0
17520 IF(ISWMDL(2).ge.1) THEN
17521 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17522 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17523 & -SIGHDD-SIGDIR
17524 IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17525 IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17526 IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17527 IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17528 IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17529 IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17530 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17531C simulate only hard scatterings
17532 ELSE
17533 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17534 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17535 ENDIF
17536
17537 ENDIF
17538
17539C reset of mother/daughter relations only (IMODE = 2)
17540
17541C debug output
17542 IF(IDEB(63).GE.15) THEN
17543 WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17544 & '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17545 IF(IMODE.LE.0) THEN
17546 WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17547 & 'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17548 & FSUP,FSUH,FSUD
17549 ONEM = -1.D0
17550 ITMP = IDEB(57)
17551 IDEB(57) = MAX(5,ITMP)
17552 CALL PHO_XSECT(1,0,ONEM)
17553 IDEB(57) = ITMP
17554 ENDIF
17555 CALL PHO_PREVNT(0)
17556 ENDIF
17557
17558 END
17559
17560*$ CREATE PHO_CSINT.FOR
17561*COPY PHO_CSINT
17562CDECK ID>, PHO_CSINT
17563 SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17564C********************************************************************
17565C
17566C calculate cross sections by interpolation
17567C
17568C input: IP particle combination
17569C IFPA/B particle PDG number
17570C IHLA/B particle helicity (photons only)
17571C ECM c.m. energy (GeV)
17572C PVIR2A virtuality of particle A (GeV**2, positive)
17573C PVIR2B virtuality of particle B (GeV**2, positive)
17574C
17575C output: cross sections stored in /POCSEC/
17576C
17577C********************************************************************
17578 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17579 SAVE
17580
17581 PARAMETER ( EPS = 1.D-5,
17582 & DEPS = 1.D-15 )
17583
17584C input/output channels
17585 INTEGER LI,LO
17586 COMMON /POINOU/ LI,LO
17587C some constants
17588 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17589 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17590 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17591C event debugging information
17592 INTEGER NMAXD
17593 PARAMETER (NMAXD=100)
17594 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17595 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17596 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17597 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17598C model switches and parameters
17599 CHARACTER*8 MDLNA
17600 INTEGER ISWMDL,IPAMDL
17601 DOUBLE PRECISION PARMDL
17602 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17603C energy-interpolation table
17604 INTEGER IEETA2
17605 PARAMETER ( IEETA2 = 20 )
17606 INTEGER ISIMAX
17607 DOUBLE PRECISION SIGTAB,SIGECM
17608 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17609C cross sections
17610 INTEGER IPFIL,IFAFIL,IFBFIL
17611 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17612 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17613 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17614 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17615 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17616 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17617 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17618 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17619 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17620 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17621 & IPFIL,IFAFIL,IFBFIL
17622C hard cross sections and MC selection weights
17623 INTEGER Max_pro_2
17624 PARAMETER ( Max_pro_2 = 16 )
17625 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17626 & MH_acc_1,MH_acc_2
17627 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17628 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17629 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17630 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17631 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17632 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17633
17634 DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17635
17636 dimension PD(-6:6),FH_T(2),FH_L(2)
17637
17638C debug
17639 IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17640 & 'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17641 & IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17642
17643C check currently stored cross sections
17644 IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17645 & .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17646 & .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17647C nothing to calculate
17648 IF(IDEB(15).GE.20)
17649 & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17650 RETURN
17651 ELSE
17652
17653C copy to local fields
17654 IFPAP(1) = IFPA
17655 IFPAP(2) = IFPB
17656 IHEL(1) = IHLA
17657 IHEL(2) = IHLB
17658 PVIRT(1) = PVIR2A
17659 PVIRT(2) = PVIR2B
17660
17661C load cross sections from interpolation table
17662 IF(ECM.LE.SIGECM(IP,1)) THEN
17663 I1 = 1
17664 I2 = 2
17665 ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17666 DO 50 I=2,ISIMAX
17667 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17668 50 CONTINUE
17669 200 CONTINUE
17670 I1 = I-1
17671 I2 = I
17672 ELSE
17673 WRITE(LO,'(/1X,A,2E12.3)')
17674 & 'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17675 CALL PHO_PREVNT(-1)
17676 I1 = ISIMAX-1
17677 I2 = ISIMAX
17678 ENDIF
17679 FAC2=0.D0
17680 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17681 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17682 FAC1=1.D0-FAC2
17683
17684C cross section dependence on photon virtualities
17685 DO 140 K=1,2
17686 FSUP(K) = 1.D0
17687 FSUD(K) = 1.D0
17688 FSUH(K) = 1.D0
17689 IF(IFPAP(K).EQ.22) THEN
17690 IF(ISWMDL(10).GE.1) THEN
17691 FSUP(K) = 0.D0
17692 FSUT(K) = 0.D0
17693 FSUL(K) = 0.D0
17694 FSUH(K) = 0.D0
17695C GVDM factors for transverse/longitudinal photons
17696 DO 150 I=1,3
17697 FSUT(K) = FSUT(K)+PARMDL(26+I)
17698 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17699 FSUL(K) = FSUL(K)
17700 & +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17701 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17702 150 CONTINUE
17703 FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17704C transverse part
17705 IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17706 FSUP(K) = FSUT(K)
17707 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17708C diffraction of trans. photons corresponds mainly to leading twist
17709 FSUD(K) = 1.D0
17710 ENDIF
17711C longitudinal (scalar) part
17712 IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17713 FSUP(K) = FSUP(K)+FSUL(K)
17714 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17715C diffraction of long. photons corresponds mainly to higher twist
17716 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17717 & /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17718 & /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17719 ENDIF
17720C debug output
17721 if(ideb(15).ge.10) then
17722 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17723 & 'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17724 & K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17725 endif
17726 ENDIF
17727 ENDIF
17728 140 CONTINUE
17729
17730 FACP = FSUP(1)*FSUP(2)
17731 FACH = FSUH(1)*FSUH(2)
17732 FACD = FSUD(1)*FSUD(2)
17733
17734C matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17735
17736 if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17737 & .and.(IPAMDL(117).gt.0)) then
17738C check kinematic limit
17739 Q2_max = max(PVIRT(1),PVIRT(2))
17740 Q2_min = min(PVIRT(1),PVIRT(2))
17741 if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17742
17743C calculate F2 from current parton density
17744 if(PVIRT(1).gt.PVIRT(2)) then
17745 K = 2
17746 else
17747 K = 1
17748 endif
17749 Q2 = Q2_max
17750 P2 = Q2_min
17751 X = Q2/(ECM**2+Q2+P2)
17752 call pho_actpdf(IFPAP(K),K)
17753 call pho_pdf(K,X,Q2,P2,PD)
17754C light quark contribution
17755 F2_light = 0.D0
17756 do j=1,3
17757 F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17758 enddo
17759C heavy quark contribution
17760 call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17761 F2_c = 2.D0*4.D0/9.D0*xpdf_c
17762 F2 = (F2_light+F2_c)
17763
17764C calculate model prediction
17765 SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17766 SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17767 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17768
17769 if(ISWMDL(10).ge.2) then
17770
17771C calculate all helicity combinations
17772 if(IPAMDL(115).eq.0) then
17773 SIGDIH = HSig(14)
17774 SIGSRH(1) = HSig(10)+HSig(11)
17775 SIGSRH(2) = HSig(12)+HSig(13)
17776 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17777C photon helicity factors
17778 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17779 FH_L(1) = 1.D0-FH_T(1)
17780 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17781 FH_L(2) = 1.D0-FH_T(2)
17782 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17783 & + SIGDIH*FH_T(1)*FH_T(2)
17784 & + SIGSRH(1)*FH_T(1)*FSUT(2)
17785 & + SIGSRH(2)*FSUT(1)*FH_T(2)
17786 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17787 & + SIGDIH*FH_T(1)*FH_L(2)
17788 & + SIGSRH(1)*FH_T(1)*FSUL(2)
17789 & + SIGSRH(2)*FSUT(1)*FH_L(2)
17790 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17791 & + SIGDIH*FH_L(1)*FH_T(2)
17792 & + SIGSRH(1)*FH_L(1)*FSUT(2)
17793 & + SIGSRH(2)*FSUL(1)*FH_T(2)
17794 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17795 & + SIGDIH*FH_L(1)*FH_L(2)
17796 & + SIGSRH(1)*FH_L(1)*FSUL(2)
17797 & + SIGSRH(2)*FSUL(1)*FH_L(2)
17798 else
17799C use explicit PDF virtuality dependence (pre-tabulated)
17800 SIGDIH = HSig(14)
17801 SIGSRH(1) = HSig(10)+HSig(11)
17802 SIGSRH(2) = HSig(12)+HSig(13)
17803 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17804 write(LO,*) ' PHO_CSINT: invalid option for F2 matching'
17805 stop
17806* CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17807* & Max_pro_2,3,4,1)
17808* SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17809* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17810* SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17811* & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17812* SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17813* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17814* SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17815* & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17816 endif
17817 Xnu = Ecm*Ecm+Q2+P2
17818 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17819 & *137.D0/GeV2mb
17820 if(K.eq.2) then
17821 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17822 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17823 & -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17824 else
17825 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17826 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17827 & -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17828 endif
17829
17830 else
17831
17832C assume sig_eff = sigtot
17833 SIGDIH = HSig(14)
17834 SIGSRH(1) = HSig(10)+HSig(11)
17835 SIGSRH(2) = HSig(12)+HSig(13)
17836 SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17837 SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17838 & +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17839 Xnu = Ecm*Ecm+Q2+P2
17840 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17841 & *137.D0/GeV2mb
17842 F2m = F2_fac*SIGeff
17843 F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17844 endif
17845* write(LO,*) ' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17846* write(LO,*) ' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
17847
17848C global factor to re-scale suppression of soft contributions
17849 Fcorr = (F2-F2m+F2s)/F2s
17850* write(LO,*) ' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
17851 FACP = FACP*Fcorr
17852
17853 endif
17854 endif
17855
17856 SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17857 SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17858 SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17859 J = 2
17860 DO 5 I=0,4
17861 DO 6 K=0,4
17862 J = J+1
17863 SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17864 & *FACP**2
17865 6 CONTINUE
17866 5 CONTINUE
17867
17868 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17869 SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17870C suppression of multi-pomeron graphs (diffraction)
17871 SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17872 & *FACP*FSUP(2)*FSUD(1)
17873 SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17874 & *FACP*FSUP(1)*FSUD(2)
17875 SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17876 & *FACP*FSUP(2)*FSUD(1)
17877 SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17878 & *FACP*FSUP(1)*FSUD(2)
17879 SIGLDD = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17880 & *FACP**2*FACD
17881 SIGHDD = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17882 SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17883 & *FACP**2
17884 SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17885 & *FACP*FSUP(2)*FSUD(1)
17886 SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17887 & *FACP*FSUP(2)*FSUD(1)
17888 SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17889 & *FACP*FSUP(1)*FSUD(2)
17890 SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17891 & *FACP*FSUP(1)*FSUD(2)
17892 SIGLOO = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17893 SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17894 & *FACP**2
17895 SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17896 & *FACP**2
17897 SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17898 & *FACP**2
17899 SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17900 & *FACP**2
17901
17902C corrections due to photon virtuality dependence of PDFs
17903 if(iswmdl(2).eq.1) then
17904 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17905C minimum bias event generation
17906 IF(IPAMDL(115).GE.1) THEN
17907C all the virtuality dependence is given by PDF parametrization
17908 SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17909 IF(IPAMDL(116).GE.2) THEN
17910C direct interaction according to full QPM calculation
17911 SIGDIH = HSig(14)
17912 SIGSRH(1) = HSig(10)+HSig(11)
17913 SIGSRH(2) = HSig(12)+HSig(13)
17914 ELSE
17915C direct interaction suppressed according to helicity factor
17916 SIGDIH = HSig(14)*FACH
17917 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17918 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17919 ENDIF
17920 write(LO,*) ' PHO_CSINT: option not supported yet'
17921 stop
17922 ELSE
17923C rescale relevant hard processes
17924 SIGDIH = HSig(14)
17925 SIGSRH(1) = HSig(10)+HSig(11)
17926 SIGSRH(2) = HSig(12)+HSig(13)
17927 SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17928 SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17929 & +SIGSRH(2)*FSUP(1)*FSUH(2)
17930 SIGINE = SIGtmp+SIGDIR
17931 SIGTOT = SIGINE+SIGELA
17932 ENDIF
17933 else
17934C only hard interactions
17935 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17936 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17937 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17938 SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17939 SIGHAR = HSig(9)*FACH
17940 endif
17941
17942 SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17943 SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17944 SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17945 J = 39
17946 DO 9 I=1,4
17947 DO 10 K=1,4
17948 J = J+1
17949 SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17950 10 CONTINUE
17951 9 CONTINUE
17952 SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17953 SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17954
17955 IPFIL = IP
17956 IFAFIL = IFPA
17957 IFBFIL = IFPB
17958 ECMFIL = ECM
17959 P2AFIL = PVIR2A
17960 P2BFIL = PVIR2B
17961
17962 IF(IDEB(15).GE.20)
17963 & WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17964
17965 ENDIF
17966
17967 END
17968
17969*$ CREATE PHO_PRIMKT.FOR
17970*COPY PHO_PRIMKT
17971CDECK ID>, PHO_PRIMKT
17972 SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17973C***********************************************************************
17974C
17975C give primordial kt to partons entering hard scatterings and
17976C remants connected to hard parton-parton interactions by color flow
17977C
17978C input: IMODE -2 output of statistics
17979C -1 initialization
17980C 1 sampling of primordial kt
17981C IF first entry in /POEVT1/ to check
17982C IL last entry in /POEVT1/ to check
17983C PTCUT current value of PTCUT to distinguish
17984C between soft and hard
17985C
17986C output: IREJ 0 success
17987C 1 failure
17988C
17989C***********************************************************************
17990
17991 IMPLICIT NONE
17992
17993 SAVE
17994
17995 DOUBLE PRECISION DEPS
17996 PARAMETER ( DEPS = 1.D-15 )
17997
17998 INTEGER IMODE,IF,IL,IREJ
17999 DOUBLE PRECISION PTCUT
18000
18001C input/output channels
18002 INTEGER LI,LO
18003 COMMON /POINOU/ LI,LO
18004C event debugging information
18005 INTEGER NMAXD
18006 PARAMETER (NMAXD=100)
18007 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18008 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18009 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18010 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18011C model switches and parameters
18012 CHARACTER*8 MDLNA
18013 INTEGER ISWMDL,IPAMDL
18014 DOUBLE PRECISION PARMDL
18015 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18016C some constants
18017 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18018 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18019 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18020C data of c.m. system of Pomeron / Reggeon exchange
18021 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18022 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18023 & SIDP,CODP,SIFP,COFP
18024 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18025 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18026 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18027C hard scattering data
18028 INTEGER MSCAHD
18029 PARAMETER ( MSCAHD = 50 )
18030 INTEGER LSCAHD,LSC1HD,LSIDX,
18031 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
18032 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
18033 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
18034 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
18035 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
18036 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
18037 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
18038 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
18039 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
18040
18041C standard particle data interface
18042 INTEGER NMXHEP
18043
18044 PARAMETER (NMXHEP=4000)
18045
18046 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18047 DOUBLE PRECISION PHEP,VHEP
18048 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18049 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18050 & VHEP(4,NMXHEP)
18051C extension to standard particle data interface (PHOJET specific)
18052 INTEGER IMPART,IPHIST,ICOLOR
18053 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18054
18055 DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
18056 DIMENSION PTS(0:2,5),XP(5),
18057 & XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
18058
18059 INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
18060
18061 PARAMETER (IRMAX=200)
18062 DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
18063
18064 DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
18065 & DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
18066 INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
18067
18068C debug output
18069 IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18070 & 'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
18071 & IMODE,IF,IL,PTCUT
18072
18073C give primordial kt to partons engaged in a hard scattering
18074
18075 IF(IMODE.EQ.1) THEN
18076
18077 ISTART = IF
18078
18079 100 CONTINUE
18080
18081 NHD = 0
18082 IBAL(1) = 0
18083 IBAL(2) = 0
18084 IROT = 0
18085 ICOM = 0
18086 DO 110 I=ISTART,IL
18087 IF(ISTHEP(I).EQ.25) THEN
18088C hard scattering number
18089 NHD = IPHIST(1,I+1)
18090 ICOM = I
18091 K = LSIDX(NHD/100)
18092C calculate momenta of incoming partons
18093 POLD(1,1) = XHD(K,1)*ECMP/2.D0
18094 POLD(2,1) = POLD(1,1)
18095 POLD(1,2) = -XHD(K,2)*ECMP/2.D0
18096 POLD(2,2) = -POLD(1,2)
18097 ISTART = I+3
18098 GOTO 150
18099 ENDIF
18100 110 CONTINUE
18101 RETURN
18102
18103 150 CONTINUE
18104
18105C search for partons involved in hard interaction
18106 INEXT = 0
18107 IROT = 0
18108 DO 500 I=ISTART,IL
18109 IF(ABS(ISTHEP(I)).EQ.1) THEN
18110C hard scatterd partons (including ISR)
18111 IF((IPHIST(1,I).EQ.-NHD)
18112 & .OR.(IPHIST(1,I).EQ.NHD+1)
18113 & .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
18114 IROT = IROT+1
18115
18116 IF(IROT.GT.IRMAX) THEN
18117 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
18118 & 'no memory left in IROTT, event rejected (max/IROT)',
18119 & IRMAX,IROT
18120 CALL PHO_PREVNT(0)
18121 IREJ = 1
18122 RETURN
18123 ENDIF
18124
18125 IROTT(IROT) = I
18126C hard remnant
18127 ELSE IF(IPHIST(1,I).EQ.NHD) THEN
18128 IF(PHEP(3,I).GT.0.D0) THEN
18129 J = 1
18130 ELSE
18131 J = 2
18132 ENDIF
18133 IBAL(J) = IBAL(J)+1
18134 IBALT(IBAL(J),J) = I
18135 XP2(IBAL(J),J) = PHEP(3,I)/ECMP
18136 IF(ISWMDL(24).EQ.0) THEN
18137 IV2(IBAL(J),J) = 0
18138 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
18139 ELSE IF(ISWMDL(24).EQ.1) THEN
18140 IV2(IBAL(J),J) = -1
18141 ELSE
18142 IV2(IBAL(J),J) = 1
18143 ENDIF
18144 ENDIF
18145C possibly further hard scattering
18146 ELSE IF(ISTHEP(I).EQ.25) THEN
18147 INEXT = 1
18148 ISTART = I
18149 GOTO 550
18150 ENDIF
18151 500 CONTINUE
18152 550 CONTINUE
18153
18154C debug output
18155 if(IDEB(10).ge.15) then
18156 WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
18157 & 'hard scattering number: ',NHD/100
18158 WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
18159 & 'number of entries to rotate: ',IROT
18160 DO I=1,IROT
18161 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
18162 & 'entries to rotate: ',I,IROTT(I)
18163 ENDDO
18164 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
18165 & 'number of entries to balance: ',IBAL
18166 DO J=1,2
18167 DO I=1,IBAL(J)
18168 WRITE(LO,'(1X,2A,I2,2I5)')
18169 & 'PHO_PRIMKT: entries to balance (side,no,line)',
18170 & J,I,IBALT(I,J)
18171 ENDDO
18172 ENDDO
18173 endif
18174
18175C incoming partons (comment lines), skip direct interacting particles
18176 DO 120 K=1,2
18177 IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
18178 IF(PHEP(3,ICOM+K).GT.0.D0) THEN
18179 J = 1
18180 ELSE
18181 J = 2
18182 ENDIF
18183 IBAL(J) = IBAL(J)+1
18184 IBALT(IBAL(J),J) = -ICOM-K
18185 XP2(IBAL(J),J) = POLD(1,J)/ECMP
18186 IV2(IBAL(J),J) = -1
18187 ENDIF
18188 120 CONTINUE
18189
18190C check consistency
18191 IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18192 WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18193 & 'inconsistent hard scattering remnant for event: ',KEVENT
18194 WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18195 & 'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18196 & IMODE,IF,IL,PTCUT
18197 WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18198 DO 390 I=1,IROT
18199 WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18200 390 CONTINUE
18201 DO 392 J=1,2
18202 DO 395 I=1,IBAL(J)
18203 WRITE(LO,'(1X,A,I2,2I5)')
18204 & 'entries to balance (side,no,line)',J,I,IBALT(I,J)
18205 395 CONTINUE
18206 392 CONTINUE
18207 IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18208 ENDIF
18209
18210C calculate primordial kt
18211
18212C something to do?
18213 IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18214
18215C add transverse momentum (overwrite /POEVT1/ entries)
18216 DO 200 J=1,2
18217 IF(IBAL(J).GT.1) THEN
18218C sample from truncated distribution
18219 K = IBAL(J)
18220 DO 180 I=1,K
18221 IV(I) = IV2(I,J)
18222 XP(I) = XP2(I,J)
18223 180 CONTINUE
18224 190 CONTINUE
18225 CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18226 IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18227C transform incoming partons of hard scattering
18228 DEL = ABS(POLD(1,J))+POLD(2,J)
18229 PT2 = PTS(0,K)**2
18230 DEL2 = DEL*DEL
18231 PNEW(1,J) = PTS(1,K)
18232 PNEW(2,J) = PTS(2,K)
18233 PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18234 PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18235C spectator partons
18236 ESUM = 0.D0
18237 DO 220 I=1,IBAL(J)-1
18238 K = IBALT(I,J)
18239 PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18240 PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18241 ESUM = ESUM+PHEP(4,K)
18242 220 CONTINUE
18243C long. momentum transfer
18244 PP(3) = PNEW(3,J) - POLD(1,J)
18245 PP(4) = PNEW(4,J) - POLD(2,J)
18246 DO 230 I=1,IBAL(J)-1
18247 K = IBALT(I,J)
18248 FAC = PHEP(4,K)/ESUM
18249 PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18250 PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18251 230 CONTINUE
18252
18253C debug output
18254 IF(IDEB(10).GE.15) THEN
18255 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18256 & 'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18257 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18258 & 'new incoming:',J,(PNEW(I,J),I=1,4)
18259 ENDIF
18260
18261 ELSE
18262 PNEW(1,J) = 0.D0
18263 PNEW(2,J) = 0.D0
18264 PNEW(3,J) = POLD(1,J)
18265 PNEW(4,J) = POLD(2,J)
18266 ENDIF
18267 200 CONTINUE
18268
18269C transformation of hard scattering final states (including ISR)
18270
18271C old parton c.m. energy
18272 SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18273 EI = SQRT(SI)
18274C new parton c.m. energy
18275 SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18276 & -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18277 EF = SQRT(SF)
18278 FAC = EF/EI
18279C debug output
18280 IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18281 & 'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18282
18283C calculate Lorentz transformation
18284 GAZ = -(POLD(1,1)+POLD(1,2))/EI
18285 GAE = (POLD(2,1)+POLD(2,2))/EI
18286 DO 240 I=1,4
18287 GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18288 240 CONTINUE
18289 CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18290 & PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18291 PTOT = MAX(DEPS,PTOT)
18292 COD= PP(3)/PTOT
18293 SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18294 COF= 1.D0
18295 SIF= 0.D0
18296 IF(PTOT*SID.GT.1.D-5) THEN
18297 COF=PP(1)/(SID*PTOT)
18298 SIF=PP(2)/(SID*PTOT)
18299 ANORF=SQRT(COF*COF+SIF*SIF)
18300 COF=COF/ANORF
18301 SIF=SIF/ANORF
18302 ENDIF
18303
18304C debug output
18305C check consistency initial/final configuration before rotation
18306 IF(IDEB(10).GE.25) THEN
18307 WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18308 & 0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18309 DO I=1,4
18310 PP(I) = 0.D0
18311 ENDDO
18312 DO I=1,IROT
18313 K = IROTT(I)
18314 DO J=1,4
18315 PP(J) = PP(J)+PHEP(J,K)
18316 ENDDO
18317 ENDDO
18318 WRITE(LO,'(1X,A,1P,4E11.3)')
18319 & 'PHO_PRIMKT: fin. momentum (1):',PP
18320 ENDIF
18321
18322C apply rotation/boost to scattered particles
18323 DO 400 I=1,IROT
18324 K = IROTT(I)
18325 DO 350 J=1,4
18326 PP(J) = FAC*PHEP(J,K)
18327 350 CONTINUE
18328 CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18329 & PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18330 CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18331 & COD,SID,COF,SIF,XX,YY,ZZ)
18332 EE = PHEP(4,K)
18333 CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18334 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18335 400 CONTINUE
18336
18337C debug output
18338C check consistency initial/final configuration after rotation
18339 IF(IDEB(10).GE.25) THEN
18340 DO I=1,4
18341 PP(I) = PNEW(I,1)+PNEW(I,2)
18342 ENDDO
18343 WRITE(LO,'(1X,A,1P,4E11.3)')
18344 & 'PHO_PRIMKT: ini. momentum (2):',PP
18345 DO I=1,4
18346 PP(I) = 0.D0
18347 ENDDO
18348 DO I=1,IROT
18349 K = IROTT(I)
18350 DO J=1,4
18351 PP(J) = PP(J)+PHEP(J,K)
18352 ENDDO
18353 ENDDO
18354 WRITE(LO,'(1X,A,1P,4E11.3)')
18355 & 'PHO_PRIMKT: fin. momentum (2):',PP
18356 ENDIF
18357
18358 ENDIF
18359
18360 IF(INEXT.EQ.1) GOTO 100
18361
18362C initialization
18363
18364 ELSE IF(IMODE.EQ.-1) THEN
18365
18366C output of statistics etc.
18367
18368 ELSE IF(IMODE.EQ.-2) THEN
18369
18370C something wrong
18371
18372 ELSE
18373 WRITE(LO,'(/1X,A,I4)')
18374 & 'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18375 CALL PHO_ABORT
18376 ENDIF
18377
18378 END
18379
18380*$ CREATE PHO_PARTPT.FOR
18381*COPY PHO_PARTPT
18382CDECK ID>, PHO_PARTPT
18383 SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18384C********************************************************************
18385C
18386C assign to soft partons
18387C
18388C input: IMODE -2 output of statistics
18389C -1 initialization
18390C 0 sampling of pt for soft partons belonging to
18391C soft Pomerons
18392C 1 sampling of pt for soft partons belonging to
18393C hard Pomerons
18394C IF first entry in /POEVT1/ to check
18395C IL last entry in /POEVT1/ to check
18396C PTCUT current value of PTCUT to distinguish
18397C between soft and hard
18398C
18399C output: IREJ 0 success
18400C 1 failure
18401C
18402C (soft pt is sampled by call to PHO_SOFTPT)
18403C
18404C********************************************************************
18405 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18406 SAVE
18407
18408 PARAMETER ( DEPS = 1.D-15 )
18409
18410 INTEGER IMODE,IF,IL,IREJ
18411 DOUBLE PRECISION PTCUT
18412
18413C input/output channels
18414 INTEGER LI,LO
18415 COMMON /POINOU/ LI,LO
18416C event debugging information
18417 INTEGER NMAXD
18418 PARAMETER (NMAXD=100)
18419 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18420 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18421 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18422 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18423C model switches and parameters
18424 CHARACTER*8 MDLNA
18425 INTEGER ISWMDL,IPAMDL
18426 DOUBLE PRECISION PARMDL
18427 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18428C some constants
18429 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18430 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18431 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18432C data of c.m. system of Pomeron / Reggeon exchange
18433 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18434 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18435 & SIDP,CODP,SIFP,COFP
18436 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18437 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18438 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18439
18440C standard particle data interface
18441 INTEGER NMXHEP
18442
18443 PARAMETER (NMXHEP=4000)
18444
18445 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18446 DOUBLE PRECISION PHEP,VHEP
18447 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18448 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18449 & VHEP(4,NMXHEP)
18450C extension to standard particle data interface (PHOJET specific)
18451 INTEGER IMPART,IPHIST,ICOLOR
18452 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18453
18454 DOUBLE PRECISION PTS,PB,XP,XPB,PC
18455 DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18456
18457 INTEGER MODIFY,IV,IVB
18458 DIMENSION MODIFY(50),IV(50),IVB(2)
18459
18460C debug output
18461 IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18462 & 'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18463 & IMODE,IF,IL,PTCUT
18464
18465 IF(IMODE.LT.0) GOTO 1000
18466
18467 IREJ = 0
18468 IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18469
18470C count entries to modify
18471 IENTRY = 0
18472 PTCUT2 = PTCUT**2
18473 EMIN = 1.D20
18474 IPEAK = 1
18475 ISTART = IF
18476
18477C soft Pomerons
18478
18479 IF(IMODE.EQ.0) THEN
18480 DO 300 I=ISTART,IL
18481 IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18482 IENTRY = IENTRY+1
18483 MODIFY(IENTRY) = I
18484 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18485 IV(IENTRY) = 0
18486 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18487 IF(PHEP(4,I).LT.EMIN) THEN
18488 EMIN = PHEP(4,I)
18489 IPEAK = IENTRY
18490 ENDIF
18491 ENDIF
18492 300 CONTINUE
18493
18494C hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18495
18496 ELSE IF(IMODE.EQ.1) THEN
18497
18498 DO 350 I=ISTART,IL
18499 IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18500 IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18501 IENTRY = IENTRY+1
18502 MODIFY(IENTRY) = I
18503 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18504 IF(ISWMDL(24).EQ.0) THEN
18505 IV(IENTRY) = 0
18506 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18507 ELSE IF(ISWMDL(24).EQ.1) THEN
18508 IV(IENTRY) = -1
18509 ELSE
18510 IV(IENTRY) = 1
18511 ENDIF
18512 IF(PHEP(4,I).LT.EMIN) THEN
18513 EMIN = PHEP(4,I)
18514 IPEAK = IENTRY
18515 ENDIF
18516 ENDIF
18517 ENDIF
18518 350 CONTINUE
18519
18520C something wrong
18521
18522 ELSE
18523 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18524 CALL PHO_ABORT
18525 ENDIF
18526
18527C debug output
18528 IF(IDEB(6).GE.5) THEN
18529 WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18530 & 'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18531 IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18532 ENDIF
18533
18534C nothing to do
18535 IF(IENTRY.LE.1) RETURN
18536
18537C sample pt of soft partons
18538
18539 IF(ISWMDL(5).LE.1) THEN
18540 ITER = 0
18541 IPEAK = DT_RNDM(DUM)*IENTRY+1
18542 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18543 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18544 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18545 400 CONTINUE
18546C energy limited sampling
18547 PSUMX = 0.D0
18548 PSUMY = 0.D0
18549 ITER = ITER+1
18550 IF(ITER.GE.1000) THEN
18551 IF(IDEB(6).GE.3) THEN
18552 WRITE(LO,'(1X,A,3I5)')
18553 & 'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18554 & IMODE,IENTRY,ITER
18555 WRITE(LO,'(8X,A,I5)') 'I II IV XP EP',
18556 & IPEAK
18557 DO 405 I=1,IENTRY
18558 II = MODIFY(I)
18559 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18560 & I,II,IV(I),XP(I),PHEP(4,II)
18561 405 CONTINUE
18562 IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18563 ENDIF
18564 IREJ = 1
18565 RETURN
18566 ENDIF
18567 DO 410 I=2,IENTRY
18568 II = MODIFY(I)
18569 PTMX = MIN(PHEP(4,II),PTCUT)
18570 XPB(1) = XP(I)
18571 IVB(1) = IV(I)
18572 IF(ISWMDL(5).EQ.0) THEN
18573 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18574 ELSE
18575 CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18576 ENDIF
18577 PTS(0,I) = PB(0,1)
18578 PTS(1,I) = PB(1,1)
18579 PTS(2,I) = PB(2,1)
18580 PSUMX = PSUMX+PB(1,1)
18581 PSUMY = PSUMY+PB(2,1)
18582 410 CONTINUE
18583 PTREM = SQRT(PSUMX**2+PSUMY**2)
18584 IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18585 PTS(1,1) = -PSUMX
18586 PTS(2,1) = -PSUMY
18587 ELSE IF((ISWMDL(5).EQ.2)
18588 & .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18589C unlimited sampling
18590 IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18591 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18592 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18593 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18594 CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18595 ELSE IF(ISWMDL(5).EQ.3) THEN
18596C each string has balanced pt
18597 DO 500 K=1,IENTRY
18598 IF(IV(K).LE.-90) GOTO 499
18599 I1 = MODIFY(K)
18600 IC1 = -ICOLOR(1,I1)
18601 DO 510 L=K+1,IENTRY
18602 IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18603 510 CONTINUE
18604 WRITE(LO,'(//1X,A,I5)')
18605 & 'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18606 CALL PHO_ABORT
18607 511 CONTINUE
18608 I2 = MODIFY(L)
18609 AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18610 & -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18611 AM = SQRT(AMSQR)
18612 PTMX = AM/2.D0
18613 IVB(1) = MAX(IV(K),IV(L))
18614 XPB(1) = XP(K)
18615 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18616 PTS(1,K) = PB(1,1)
18617 PTS(2,K) = PB(2,1)
18618 PTS(1,L) = -PB(1,1)
18619 PTS(2,L) = -PB(2,1)
18620 GAM = (PHEP(4,I1)+PHEP(4,I2))/AM
18621 GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18622 PC(1) = PB(1,1)
18623 PC(2) = PB(2,1)
18624 PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18625 PC(3) = SIGN(PLONG,PHEP(3,I1))
18626 PC(4) = PTMX
18627 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18628 & PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18629 PC(1) = -PC(1)
18630 PC(2) = -PC(2)
18631 PC(3) = -PC(3)
18632 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18633 & PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18634 IV(K) = IV(K)-100
18635 IV(L) = IV(L)-100
18636 499 CONTINUE
18637 500 CONTINUE
18638 ELSE
18639 WRITE(LO,'(/1X,A,I4)')
18640 & 'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18641 CALL PHO_ABORT
18642 ENDIF
18643
18644C change partons in /POEVT1/
18645 DO 900 II=1,IENTRY
18646 IF(IV(II).GT.-90) THEN
18647 I = MODIFY(II)
18648 PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18649 PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18650 AMSQR = PHEP(4,I)**2
18651 & -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18652 PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18653 ENDIF
18654 900 CONTINUE
18655
18656C debug output
18657 IF(IDEB(6).GE.15) THEN
18658 WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18659 & 'I II IV XP EP PTS PTX PTY',IPEAK
18660 DO 505 I=1,IENTRY
18661 II = MODIFY(I)
18662 WRITE(LO,'(2X,3I5,1P,5E12.4)')
18663 & I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18664 505 CONTINUE
18665 CALL PHO_PREVNT(0)
18666 ENDIF
18667 RETURN
18668
18669C initialization / output of statistics
18670 1000 CONTINUE
18671 CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18672
18673 END
18674
18675*$ CREATE PHO_SOFTPT.FOR
18676*COPY PHO_SOFTPT
18677CDECK ID>, PHO_SOFTPT
18678 SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18679C***********************************************************************
18680C
18681C select pt of soft string ends
18682C
18683C input: ISOFT number of soft partons
18684C -1 initialization
18685C >=0 sampling of p_t
18686C -2 output of statistics
18687C PTCUT cutoff for soft strings
18688C PTMAX maximal allowed PT
18689C XV field of x values
18690C IV 0 sea quark
18691C 1 valence quark
18692C
18693C output: /POINT3/ containing parameters AAS,BETAS
18694C PTSOF filed with soft pt values
18695C
18696C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18697C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18698C ISWMDL(3/4) = 2 photon wave function
18699C ISWMDL(3/4) = 10 no soft P_t assignment
18700C
18701C***********************************************************************
18702 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18703 SAVE
18704
18705 PARAMETER ( DEPS = 1.D-15)
18706
18707 DIMENSION PTSOF(0:2,*),XV(*)
18708 DIMENSION IV(*)
18709
18710C input/output channels
18711 INTEGER LI,LO
18712 COMMON /POINOU/ LI,LO
18713C event debugging information
18714 INTEGER NMAXD
18715 PARAMETER (NMAXD=100)
18716 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18717 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18718 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18719 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18720C model switches and parameters
18721 CHARACTER*8 MDLNA
18722 INTEGER ISWMDL,IPAMDL
18723 DOUBLE PRECISION PARMDL
18724 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18725C data of c.m. system of Pomeron / Reggeon exchange
18726 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18727 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18728 & SIDP,CODP,SIFP,COFP
18729 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18730 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18731 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18732C data on most recent hard scattering
18733 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18734 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18735 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18736 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18737 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18738 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18739 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18740 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18741 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18742C data needed for soft-pt calculation
18743 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18744 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18745
18746 DIMENSION BETAB(100)
18747
18748C selection of pt
18749 IF(ISOFT.GE.0) THEN
18750 CALLS = CALLS + 1.D0
18751C sample according to model ISWMDL(3-6)
18752 IF(ISOFT.GT.1) THEN
18753 210 CONTINUE
18754 PTXS = 0.D0
18755 PTYS = 0.D0
18756 DO 300 I=2,ISOFT
18757 IMODE = ISWMDL(3)
18758C valence partons
18759 IF(IV(I).EQ.1) THEN
18760 BETA = BETAS(1)
18761C photon/pomeron valence part
18762 IF(IPAMDL(5).EQ.1) THEN
18763 IF(XV(I).GE.0.D0) THEN
18764 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18765 IMODE = ISWMDL(4)
18766 BETA = BETAS(3)
18767 ENDIF
18768 ELSE
18769 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18770 IMODE = ISWMDL(4)
18771 BETA = BETAS(3)
18772 ENDIF
18773 ENDIF
18774 ELSE IF(IPAMDL(5).EQ.2) THEN
18775 BETA = PARMDL(20)
18776 ELSE IF(IPAMDL(5).EQ.3) THEN
18777 BETA = BETAS(3)
18778 ENDIF
18779C sea partons
18780 ELSE IF(IV(I).EQ.0) THEN
18781 BETA = BETAS(3)
18782C hard scattering remnant
18783 ELSE
18784 IF(IPAMDL(6).EQ.0) THEN
18785 BETA = BETAS(1)
18786 ELSE IF(IPAMDL(6).EQ.1) THEN
18787 BETA = BETAS(3)
18788 ELSE
18789 BETA = PARMDL(20)
18790 ENDIF
18791 ENDIF
18792 BETA = MAX(BETA,0.01D0)
18793 CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18794 PTS = MIN(PTMAX,PTS)
18795 CALL PHO_SFECFE(SIG,COG)
18796 PTSOF(0,I) = PTS
18797 PTSOF(1,I) = COG*PTS
18798 PTSOF(2,I) = SIG*PTS
18799 PTXS = PTXS+PTSOF(1,I)
18800 PTYS = PTYS+PTSOF(2,I)
18801 BETAB(I) = BETA
18802 300 CONTINUE
18803C balancing of momenta
18804 PTS = SQRT(PTXS**2+PTYS**2)
18805 IF(PTS.GE.PTMAX) GOTO 210
18806 PTSOF(0,1) = PTS
18807 PTSOF(1,1) = -PTXS
18808 PTSOF(2,1) = -PTYS
18809 BETAB(1) = 0.D0
18810C
18811*400 CONTINUE
18812C
18813C single parton only
18814 ELSE
18815 IMODE = ISWMDL(3)
18816C valence partons
18817 IF(IV(1).EQ.1) THEN
18818 BETA = BETAS(1)
18819C photon/Pomeron valence part
18820 IF(IPAMDL(5).EQ.1) THEN
18821 IF(XV(1).GE.0.D0) THEN
18822 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18823 IMODE = ISWMDL(4)
18824 BETA = BETAS(3)
18825 ENDIF
18826 ELSE
18827 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18828 IMODE = ISWMDL(4)
18829 BETA = BETAS(3)
18830 ENDIF
18831 ENDIF
18832 ELSE IF(IPAMDL(5).EQ.2) THEN
18833 BETA = PARMDL(20)
18834 ELSE IF(IPAMDL(5).EQ.3) THEN
18835 BETA = BETAS(3)
18836 ENDIF
18837C sea partons
18838 ELSE IF(IV(1).EQ.0) THEN
18839 BETA = BETAS(3)
18840C hard scattering remnant
18841 ELSE
18842 IF(IPAMDL(6).EQ.1) THEN
18843 BETA = BETAS(3)
18844 ELSE
18845 BETA = PARMDL(20)
18846 ENDIF
18847 ENDIF
18848 BETA = MAX(BETA,0.01D0)
18849 CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18850 PTS = MIN(PTMAX,PTS)
18851 CALL PHO_SFECFE(SIG,COG)
18852 PTSOF(0,1) = PTS
18853 PTSOF(1,1) = COG*PTS
18854 PTSOF(2,1) = SIG*PTS
18855 BETAB(1) = BETA
18856 ENDIF
18857
18858C debug output
18859 IF(IDEB(29).GE.10) THEN
18860 WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18861 WRITE(LO,'(6X,A)') 'TABLE OF I, IV, XV, PT, PT-X, PT-Y, BETA'
18862 DO 105 I=1,ISOFT
18863 WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18864 & PTSOF(1,I),PTSOF(2,I),BETAB(I)
18865 105 CONTINUE
18866 ENDIF
18867
18868C initialization of statistics and parameters
18869
18870 ELSE IF(ISOFT.EQ.-1) THEN
18871 PTSMIN = 0.D0
18872 PTSMAX = PTCUT
18873
18874 IMODE = -100+ISWMDL(3)
18875 CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18876
18877C output of statistics
18878
18879 ELSE IF(ISOFT.EQ.-2) THEN
18880
18881 ELSE
18882 WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18883 & 'unsupported ISOFT ',ISOFT
18884 STOP
18885 ENDIF
18886 END
18887
18888*$ CREATE PHO_SELPT.FOR
18889*COPY PHO_SELPT
18890CDECK ID>, PHO_SELPT
18891 SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18892C***********************************************************************
18893C
18894C select pt from different distributions
18895C
18896C input: EE energy (for initialization only)
18897C otherwise x value of corresponding parton
18898C PTLOW lower pt limit
18899C PTHIGH upper pt limit
18900C (PTHIGH > 20 will cause DEXP underflows)
18901C
18902C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18903C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18904C IMODE = 2 dNs/dP_t according photon wave function
18905C IMODE = 10 no sampling
18906C
18907C IMODE = -100+IMODE initialization according to
18908C given limitations
18909C
18910C output: PTS sampled pt value
18911C initialization:
18912C BETA soft pt slope in central region
18913C
18914C***********************************************************************
18915 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18916 SAVE
18917
18918 PARAMETER ( PI2 = 6.28318530718D0,
18919 & AMIN = 1.D-2,
18920 & EPS = 1.D-7,
18921 & DEPS = 1.D-30)
18922
18923C input/output channels
18924 INTEGER LI,LO
18925 COMMON /POINOU/ LI,LO
18926C event debugging information
18927 INTEGER NMAXD
18928 PARAMETER (NMAXD=100)
18929 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18930 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18931 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18932 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18933C model switches and parameters
18934 CHARACTER*8 MDLNA
18935 INTEGER ISWMDL,IPAMDL
18936 DOUBLE PRECISION PARMDL
18937 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18938C data of c.m. system of Pomeron / Reggeon exchange
18939 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18940 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18941 & SIDP,CODP,SIFP,COFP
18942 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18943 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18944 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18945C average number of cut soft and hard ladders (obsolete)
18946 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18947 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18948C data needed for soft-pt calculation
18949 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18950 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18951
18952 DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18953 EXTERNAL PHO_CONN0,PHO_CONN1
18954
18955C initialization
18956
18957 IF(IMODE.LT.0) GOTO 100
18958
18959 PX = PTHIGH
18960 PTS = 0.D0
18961
18962C initial checks
18963
18964 IF(PX.LT.AMIN) RETURN
18965
18966 IF((PX-PTLOW).LT.0.01) THEN
18967 IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18968 & 'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18969 RETURN
18970 ENDIF
18971
18972C sampling of pt values according to IMODE
18973
18974 IF(IMODE.EQ.0) THEN
18975
18976 FAC1 = EXP(-BETA*PX**2)
18977 FAC2 = (1.D0-FAC1)
18978 25 CONTINUE
18979 XI1 = DT_RNDM(PX)*FAC2 + FAC1
18980 PTS = SQRT(-1.D0/BETA*LOG(XI1))
18981 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18982
18983 ELSE IF(IMODE.EQ.1) THEN
18984
18985 XIMIN = EXP(-BETA*PTHIGH)
18986 XIDEL = 1.D0-XIMIN
18987 50 CONTINUE
18988 PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18989 & *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18990 IF(PTS.LT.XMT) GOTO 50
18991 PTS = SQRT(PTS**2-XMT2)
18992 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18993
18994 ELSE IF(IMODE.EQ.2) THEN
18995
18996 IF(EE.GE.0.D0) THEN
18997 P2 = PVIRTP(1)
18998 ELSE
18999 P2 = PVIRTP(2)
19000 ENDIF
19001 XV = ABS(EE)
19002 AA = (1.D0-XV)*XV*P2+PARMDL(25)
19003 75 CONTINUE
19004 PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
19005 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
19006
19007C something wrong
19008
19009 ELSE IF(IMODE.NE.10) THEN
19010 WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
19011 CALL PHO_ABORT
19012 ENDIF
19013
19014C debug output
19015 IF(IDEB(5).GE.20) THEN
19016 WRITE(LO,'(1X,A,I3,4E10.3)')
19017 & 'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
19018 & IMODE,BETA,PTLOW,PTHIGH,PTS
19019 ENDIF
19020 RETURN
19021
19022C initialization
19023 100 CONTINUE
19024 PTSMIN = PTLOW
19025 PTSMAX = PTHIGH
19026 PTCON = PTHIGH
19027C calculation of parameters
19028 INIT = IMODE+100
19029 AAS = 0.D0
19030
19031C initialization for model 0 (gaussian pt distribution)
19032
19033 IF(INIT.EQ.0) THEN
19034 BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
19035 BETUP = BETAS(1)
19036 BETLO = -2.D0
19037 XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
19038 IF(XTOL.LT.0.D0) THEN
19039 XTOL = 1.D-4
19040 METHOD = 1
19041 MAXF = 500
19042 BETA = 0.D0
19043 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
19044* IF(BETA.LT.-1.D+10) THEN
19045* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
19046* & '(model 0: Ecm,PTcut)',EE,PTCON
19047* WRITE(LO,'(1X,A,1P,3E10.3)')
19048* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
19049* CALL PHO_PREVNT(-1)
19050* BETA = 0.01
19051* ELSE
19052 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
19053* ENDIF
19054 ELSE
19055 AAS = 0.D0
19056 BETA = BETAS(1)
19057 ENDIF
19058
19059C initialization for model 1 (exponential pt distribution)
19060
19061 ELSE IF(INIT.EQ.1) THEN
19062 XMT = PARMDL(43)
19063 XMT2 = XMT*XMT
19064 BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
19065 BETUP = BETAS(1)
19066 BETLO = -3.D0
19067 XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
19068 IF(XTOL.LT.0.D0) THEN
19069 XTOL = 1.D-4
19070 METHOD = 1
19071 MAXF = 500
19072 BETA = 0.D0
19073 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
19074* IF(BETA.LT.-1.D+10) THEN
19075* WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
19076* & '(model 1: Ecm,PTcut)',EE,PTCON
19077* WRITE(LO,'(1X,A,1P,3E10.3)')
19078* & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
19079* CALL PHO_PREVNT(-1)
19080* BETA = 0.01
19081* ELSE
19082 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
19083* ENDIF
19084 ELSE
19085 AAS = 0.D0
19086 BETA = BETAS(1)
19087 ENDIF
19088 ELSE IF(INIT.EQ.10) THEN
19089 IF(IDEB(5).GT.10)
19090 & WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
19091 RETURN
19092 ELSE
19093 WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
19094 & INIT
19095 CALL PHO_ABORT
19096 ENDIF
19097 BETA = MIN(BETA,BETAS(1))
19098
19099C hard cross section is too big: neg. beta parameter
19100 IF(BETA.LE.0.D0) THEN
19101 WRITE(LO,'(1X,A,1P,2E12.3)')
19102 & 'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
19103 WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
19104 & SIGS,DSIGHP,SIGH,PTCON
19105 CALL PHO_PREVNT(-1)
19106 ENDIF
19107
19108C output of initialization parameters
19109 IF(IDEB(5).GE.10) THEN
19110 WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
19111 & INIT
19112 WRITE(LO,'(5X,A,1P,2E13.3)')
19113 & 'BETA,AAS ',BETA,AAS
19114 WRITE(LO,'(5X,A,1P,3E13.3)')
19115 & 'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
19116 WRITE(LO,'(5X,A,1P,3E13.3)')
19117 & 'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
19118 ENDIF
19119
19120 END
19121
19122*$ CREATE PHO_CONN0.FOR
19123*COPY PHO_CONN0
19124CDECK ID>, PHO_CONN0
19125 DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
19126C***********************************************************************
19127C
19128C auxiliary function to determine parameters of soft
19129C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
19130C
19131C internal factors: FS number of soft partons in soft Pomeron
19132C FH number of soft partons in hard Pomeron
19133C
19134C***********************************************************************
19135
19136 IMPLICIT NONE
19137
19138 SAVE
19139
19140C input/output channels
19141 INTEGER LI,LO
19142 COMMON /POINOU/ LI,LO
19143C average number of cut soft and hard ladders (obsolete)
19144 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19145 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19146C data needed for soft-pt calculation
19147 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19148 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19149
19150 DOUBLE PRECISION BETA,XX,FF
19151
19152 XX = BETA*PTCON**2
19153 IF(ABS(XX).LT.1.D-3) THEN
19154 FF = FS*SIGS+FH*SIGH
19155 & - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
19156 ELSE
19157 FF = FS*SIGS+FH*SIGH
19158 & - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
19159 ENDIF
19160 PHO_CONN0 = FF
19161
19162* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
19163* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19164
19165 END
19166
19167*$ CREATE PHO_CONN1.FOR
19168*COPY PHO_CONN1
19169CDECK ID>, PHO_CONN1
19170 DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
19171C***********************************************************************
19172C
19173C auxiliary function to determine parameters of soft
19174C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
19175C
19176C internal factors: FS number of soft partons in soft Pomeron
19177C FH number of soft partons in hard Pomeron
19178C
19179C***********************************************************************
19180
19181 IMPLICIT NONE
19182
19183 SAVE
19184
19185C input/output channels
19186 INTEGER LI,LO
19187 COMMON /POINOU/ LI,LO
19188C average number of cut soft and hard ladders (obsolete)
19189 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19190 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19191C data needed for soft-pt calculation
19192 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19193 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19194
19195 DOUBLE PRECISION BETA,XX,FF
19196
19197 XX = BETA*PTCON
19198 IF(ABS(XX).LT.1.D-3) THEN
19199 FF = FS*SIGS+FH*SIGH
19200 & - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
19201 ELSE
19202 FF = FS*SIGS+FH*SIGH
19203 & - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19204 ENDIF
19205 PHO_CONN1 = FF
19206
19207* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19208* WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19209
19210 END
19211
19212*$ CREATE PHO_MSHELL.FOR
19213*COPY PHO_MSHELL
19214CDECK ID>, PHO_MSHELL
19215 SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19216C********************************************************************
19217C
19218C rescaling of momenta of two partons to put both
19219C on mass shell
19220C
19221C input: PA1,PA2 input momentum vectors
19222C XM1,2 desired masses of particles afterwards
19223C P1,P2 changed momentum vectors
19224C
19225C********************************************************************
19226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19227 SAVE
19228
19229 PARAMETER ( DEPS = 1.D-20 )
19230
19231 DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19232
19233C input/output channels
19234 INTEGER LI,LO
19235 COMMON /POINOU/ LI,LO
19236C event debugging information
19237 INTEGER NMAXD
19238 PARAMETER (NMAXD=100)
19239 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19240 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19241 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19242 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19243C internal rejection counters
19244 INTEGER NMXJ
19245 PARAMETER (NMXJ=60)
19246 CHARACTER*10 REJTIT
19247 INTEGER IFAIL
19248 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19249
19250 IREJ = 0
19251 IDEV = 0
19252C debug output
19253 IF(IDEB(40).GE.10) THEN
19254 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19255 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19256 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19257 WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19258 ENDIF
19259
19260C Lorentz transformation into system CMS
19261 PX = PA1(1)+PA2(1)
19262 PY = PA1(2)+PA2(2)
19263 PZ = PA1(3)+PA2(3)
19264 EE = PA1(4)+PA2(4)
19265 XMS = EE**2-PX**2-PY**2-PZ**2
19266 IF(XMS.LT.(XM1+XM2)**2) THEN
19267 IREJ = 1
19268 IFAIL(37) = IFAIL(37)+1
19269
19270 if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19271
19272 IF(IDEB(40).GE.3) THEN
19273 WRITE(LO,'(/1X,A,I12)')
19274 & 'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19275 WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19276 & SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19277 WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19278 IDEV = 5
19279 IF(IDEB(40).GE.3) GOTO 55
19280 ENDIF
19281 RETURN
19282 ENDIF
19283 XMS = SQRT(XMS)
19284 BGX = PX/XMS
19285 BGY = PY/XMS
19286 BGZ = PZ/XMS
19287 GAM = EE/XMS
19288 CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19289 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19290C rotation angles
19291 PTOT1 = MAX(DEPS,PTOT1)
19292 COD = P1(3)/PTOT1
19293 SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19294 COF = 1.D0
19295 SIF = 0.D0
19296 IF(PTOT1*SID.GT.1.D-5) THEN
19297 COF = P1(1)/(SID*PTOT1)
19298 SIF = P1(2)/(SID*PTOT1)
19299 ANORF = SQRT(COF*COF+SIF*SIF)
19300 COF = COF/ANORF
19301 SIF = SIF/ANORF
19302 ENDIF
19303
19304C new CM momentum and energies (for masses XM1,XM2)
19305 XM12 = XM1**2
19306 XM22 = XM2**2
19307 SS = XMS**2
19308 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19309 EE1 = SQRT(XM12+PCMP**2)
19310 EE2 = XMS-EE1
19311C back rotation
19312 CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19313 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19314 & PTOT1,P1(1),P1(2),P1(3),P1(4))
19315 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19316 & PTOT2,P2(1),P2(2),P2(3),P2(4))
19317
19318C check consistency
19319 DEL = XMS*0.0001
19320 IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19321 IDEV = 1
19322 ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19323 IDEV = 2
19324 ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19325 IDEV = 3
19326 ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19327 IDEV = 4
19328 ENDIF
19329 55 CONTINUE
19330C debug output
19331 IF(IDEV.NE.0) THEN
19332 WRITE(LO,'(1X,A,I3)')
19333 & 'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19334 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19335 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19336 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19337 WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19338 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19339 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19340 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19341 ELSE IF(IDEB(40).GE.10) THEN
19342 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19343 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19344 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19345 ENDIF
19346 END
19347
19348*$ CREATE PHO_GLU2QU.FOR
19349*COPY PHO_GLU2QU
19350CDECK ID>, PHO_GLU2QU
19351 SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19352C********************************************************************
19353C
19354C split gluon with index I in POEVT1
19355C (massless gluon assumed)
19356C
19357C input: /POEVT1/
19358C IG gluon index
19359C IQ1 first quark index
19360C IQ2 second quark index
19361C
19362C output: new quarks in /POEVT1/
19363C IREJ 1 splitting impossible
19364C 0 splitting successful
19365C
19366C********************************************************************
19367 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19368 SAVE
19369
19370 PARAMETER ( DEPS = 1.D-15,
19371 & EPS = 1.D-5 )
19372
19373C input/output channels
19374 INTEGER LI,LO
19375 COMMON /POINOU/ LI,LO
19376C event debugging information
19377 INTEGER NMAXD
19378 PARAMETER (NMAXD=100)
19379 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19380 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19381 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19382 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19383C model switches and parameters
19384 CHARACTER*8 MDLNA
19385 INTEGER ISWMDL,IPAMDL
19386 DOUBLE PRECISION PARMDL
19387 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19388
19389C standard particle data interface
19390 INTEGER NMXHEP
19391
19392 PARAMETER (NMXHEP=4000)
19393
19394 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19395 DOUBLE PRECISION PHEP,VHEP
19396 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19397 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19398 & VHEP(4,NMXHEP)
19399C extension to standard particle data interface (PHOJET specific)
19400 INTEGER IMPART,IPHIST,ICOLOR
19401 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19402
19403C internal rejection counters
19404 INTEGER NMXJ
19405 PARAMETER (NMXJ=60)
19406 CHARACTER*10 REJTIT
19407 INTEGER IFAIL
19408 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19409
19410 DIMENSION P1(4),P2(4)
19411 DATA CUTM /0.02D0/
19412
19413 IREJ = 0
19414
19415C calculate string masses max possible
19416 IF(ISWMDL(9).EQ.1) THEN
19417 CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19418 & -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19419 IF(CMASS1.LT.CUTM) THEN
19420 IF(IDEB(73).GE.5) THEN
19421 WRITE(LO,'(1X,A,3I4,4E10.3)')
19422 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19423 ENDIF
19424 IFAIL(33) = IFAIL(33) + 1
19425 IREJ = 1
19426 RETURN
19427 ENDIF
19428 CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19429 & -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19430 IF(CMASS2.LT.CUTM) THEN
19431 IF(IDEB(73).GE.5) THEN
19432 WRITE(LO,'(1X,A,3I4,4E10.3)')
19433 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19434 ENDIF
19435 IFAIL(33) = IFAIL(33) + 1
19436 IREJ = 1
19437 RETURN
19438 ENDIF
19439C
19440C calculate minimal z
19441 ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19442 ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19443 ZMIN = MIN(ZMIN1,ZMIN2)
19444 IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19445 IF(IDEB(73).GE.5) THEN
19446 WRITE(LO,'(1X,A,3I3,4E10.3)')
19447 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19448 & IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19449 ENDIF
19450 IFAIL(33) = IFAIL(33) + 1
19451 IREJ = 1
19452 RETURN
19453 ENDIF
19454 ELSE
19455 ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19456 ENDIF
19457C
19458 ZFRAC = PHO_GLUSPL(ZMIN)
19459 IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19460 ZFRAC = 1.D0-ZFRAC
19461 ENDIF
19462 DO 200 I=1,4
19463 P1(I) = PHEP(I,IG)*ZFRAC
19464 P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19465 200 CONTINUE
19466C quark flavours
19467 CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19468 CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19469 & +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19470 CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19471
19472 IF(ABS(IDHEP(IQ1)).GT.6) THEN
19473 K = SIGN(ABS(K),IDHEP(IQ1))
19474 ELSE
19475 K = -SIGN(ABS(K),IDHEP(IQ1))
19476 ENDIF
19477C colors
19478 IF(K.GT.0) THEN
19479 IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19480 IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19481 ELSE
19482 IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19483 IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19484 ENDIF
19485C register new partons
19486 CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19487 & IPHIST(1,IG),0,IC1,0,IPOS,1)
19488 CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19489 & IPHIST(1,IG),0,IC2,0,IPOS,1)
19490C debug output
19491 IF(IDEB(73).GE.20) THEN
19492 WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19493 & 'PHO_GLU2QU:',' IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19494 & IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19495 WRITE(LO,'(1X,A,4I5)') ' flavours, colors ',
19496 & K,-K,IC1,IC2
19497 ENDIF
19498 END
19499
19500*$ CREATE PHO_GLUSPL.FOR
19501*COPY PHO_GLUSPL
19502CDECK ID>, PHO_GLUSPL
19503 DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19504C*********************************************************************
19505C
19506C calculate quark - antiquark light cone momentum fractions
19507C according to Altarelli-Parisi g->q aq splitting function
19508C (symmetric z interval assumed)
19509C
19510C input: ZMIN minimal Z value allowed,
19511C 1-ZMIN maximal Z value allowed
19512C
19513C********************************************************************
19514 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19515 SAVE
19516
19517 PARAMETER ( ALEXP= 0.3333333333D0,
19518 & DEPS = 1.D-10 )
19519
19520C input/output channels
19521 INTEGER LI,LO
19522 COMMON /POINOU/ LI,LO
19523C event debugging information
19524 INTEGER NMAXD
19525 PARAMETER (NMAXD=100)
19526 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19527 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19528 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19529 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19530
19531 IF(ZMIN.GE.0.5D0) THEN
19532 IF(IDEB(69).GT.2) THEN
19533 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19534 ENDIF
19535 ZZ=0.D0
19536 GOTO 1000
19537 ELSE IF(ZMIN.LE.0.D0) THEN
19538 IF(IDEB(69).GT.2) THEN
19539 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19540 ENDIF
19541 ZMINL = DEPS
19542 ELSE
19543 ZMINL = ZMIN
19544 ENDIF
19545
19546 ZMAX = 1.D0-ZMINL
19547 XI = DT_RNDM(ZMAX)
19548 ZZ = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19549 IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19550
19551 1000 CONTINUE
19552 IF(IDEB(69).GE.10) THEN
19553 WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19554 ENDIF
19555 PHO_GLUSPL = ZZ
19556 END
19557
19558*$ CREATE PHO_STDPAR.FOR
19559*COPY PHO_STDPAR
19560CDECK ID>, PHO_STDPAR
19561 SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19562C***********************************************************************
19563C
19564C select the initial parton x-fractions and flavors and
19565C the final parton momenta and flavours
19566C for standard Pomeron/Reggeon cuts
19567C
19568C input: IJM1 index of mother particle 1 in /POEVT1/
19569C IJM2 index of mother particle 2 in /POEVT1/
19570C IGEN production process of mother particles
19571C MSPOM soft cut Pomerons
19572C MHPOM hard or semihard cut Pomerons
19573C MSREG soft cut Reggeons
19574C MHDIR direct hard processes
19575C
19576C IJM1 -1 initialization of statistics
19577C -2 output of statistics
19578C
19579C output: partons are directly written to /POEVT1/,/POEVT2/
19580C
19581C structure of /POSOFT/
19582C XS1(I),XS2(I): x-values of initial partons
19583C IJSI1(I),IJSI2(I): flavor of initial parton
19584C 0 gluon
19585C 1,2,3,4 quarks
19586C negative antiquarks
19587C IJSF1(I),IJSF2(I): flavor of final state partons
19588C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19589C J=1 PX
19590C =2 PY
19591C =3 PZ
19592C =4 ENERGY
19593C
19594C***********************************************************************
19595 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19596 SAVE
19597
19598 PARAMETER (RHOMAS = 0.766D0,
19599 & DEPS = 1.D-10,
19600 & TINY = 1.D-10)
19601
19602C input/output channels
19603 INTEGER LI,LO
19604 COMMON /POINOU/ LI,LO
19605C event debugging information
19606 INTEGER NMAXD
19607 PARAMETER (NMAXD=100)
19608 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19609 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19610 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19611 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19612C model switches and parameters
19613 CHARACTER*8 MDLNA
19614 INTEGER ISWMDL,IPAMDL
19615 DOUBLE PRECISION PARMDL
19616 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19617C some constants
19618 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19619 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19620 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19621C general process information
19622 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19623 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19624C global event kinematics and particle IDs
19625 INTEGER IFPAP,IFPAB
19626 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19627 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19628C data of c.m. system of Pomeron / Reggeon exchange
19629 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19630 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19631 & SIDP,CODP,SIFP,COFP
19632 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19633 & SIDP,CODP,SIFP,COFP,NPOSP(2),
19634 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
19635C nucleon-nucleus / nucleus-nucleus interface to DPMJET
19636 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19637 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19638 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19639 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19640C obsolete cut-off information
19641 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19642 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19643C currently activated parton density parametrizations
19644 CHARACTER*8 PDFNAM
19645 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19646 DOUBLE PRECISION PDFLAM,PDFQ2M
19647 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19648 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19649C hard scattering parameters used for most recent hard interaction
19650 INTEGER NFbeta,NF
19651 DOUBLE PRECISION ALQCD2,BQCD
19652 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19653C particles created by initial state evolution
19654 INTEGER MXISR1,MXISR2
19655 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19656 INTEGER IFLISR,IPOISR,IMXISR
19657 DOUBLE PRECISION PHISR
19658 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19659 & IPOISR(2,2,MXISR2),IMXISR(2)
19660C light-cone x fractions and c.m. momenta of soft cut string ends
19661 INTEGER MAXSOF
19662 PARAMETER ( MAXSOF = 50 )
19663 INTEGER IJSI2,IJSI1
19664 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19665 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19666 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19667 & IJSI1(MAXSOF),IJSI2(MAXSOF)
19668C table of particle indices for recursive PHOJET calls
19669 INTEGER MAXIPX
19670 PARAMETER ( MAXIPX = 100 )
19671 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19672 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19673 & IPOIX1,IPOIX2,IPOIX3
19674C hard scattering data
19675 INTEGER MSCAHD
19676 PARAMETER ( MSCAHD = 50 )
19677 INTEGER LSCAHD,LSC1HD,LSIDX,
19678 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19679 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19680 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19681 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19682 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19683 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19684 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19685 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19686 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19687
19688C standard particle data interface
19689 INTEGER NMXHEP
19690
19691 PARAMETER (NMXHEP=4000)
19692
19693 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19694 DOUBLE PRECISION PHEP,VHEP
19695 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19696 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19697 & VHEP(4,NMXHEP)
19698C extension to standard particle data interface (PHOJET specific)
19699 INTEGER IMPART,IPHIST,ICOLOR
19700 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19701
19702C internal rejection counters
19703 INTEGER NMXJ
19704 PARAMETER (NMXJ=60)
19705 CHARACTER*10 REJTIT
19706 INTEGER IFAIL
19707 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19708C internal cross check information on hard scattering limits
19709 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19710 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19711C hard cross sections and MC selection weights
19712 INTEGER Max_pro_2
19713 PARAMETER ( Max_pro_2 = 16 )
19714 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19715 & MH_acc_1,MH_acc_2
19716 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19717 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19718 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19719 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19720 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19721 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19722
19723 double precision pho_alphas
19724
19725 DIMENSION PC(4),IFLA(2),ICI(2,2)
19726
19727 IF(IJM1.EQ.-1) THEN
19728 DO 116 I=1,15
19729 ETAMI(1,I) = 1.D10
19730 ETAMA(1,I) = -1.D10
19731 ETAMI(2,I) = 1.D10
19732 ETAMA(2,I) = -1.D10
19733 XXMI(1,I) = 1.D0
19734 XXMA(1,I) = 0.D0
19735 XXMI(2,I) = 1.D0
19736 XXMA(2,I) = 0.D0
19737 116 CONTINUE
19738 CALL PHO_HARSCA(IJM1,1)
19739 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19740
19741 RETURN
19742
19743 ELSE IF(IJM1.EQ.-2) THEN
19744
19745C output internal statistics
19746 IF(IDEB(23).GE.1) THEN
19747 WRITE(LO,'(/1X,A)')
19748 & 'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19749 DO 117 I=1,15
19750 WRITE(LO,'(5X,I3,4E13.5)')
19751 & I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19752 117 CONTINUE
19753 WRITE(LO,'(1X,A)')
19754 & 'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19755 DO 118 I=1,15
19756 WRITE(LO,'(5X,I3,4E13.5)')
19757 & I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
19758 118 CONTINUE
19759 ENDIF
19760 CALL PHO_HARSCA(IJM1,1)
19761 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19762
19763 RETURN
19764 ENDIF
19765
19766 IREJ = 0
19767C debug output
19768 IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19769 221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19770
19771C get mother data (exchange if first particle is a pomeron)
19772 IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19773 JM1 = IJM2
19774 JM2 = IJM1
19775 ELSE
19776 JM1 = IJM1
19777 JM2 = IJM2
19778 ENDIF
19779
19780 NPOSP(1) = JM1
19781 NPOSP(2) = JM2
19782 IDPDG1 = IDHEP(JM1)
19783 IDBAM1 = IMPART(JM1)
19784 IDPDG2 = IDHEP(JM2)
19785 IDBAM2 = IMPART(JM2)
19786
19787C store current status of /POEVT1/
19788 KHPOMS = KHPOM
19789 KSPOMS = KSPOM
19790 KSREGS = KSREG
19791 KHDIRS = KHDIR
19792 NHEPS = NHEP
19793 IPOIS1 = IPOIX1
19794 IPOIS2 = IPOIX2
19795
19796C get nominal masses (photons: VDM assumption)
19797 DELMAS = 0.D0
19798 IF(IDHEP(JM1).EQ.22) THEN
19799 PMASSP(1) = RHOMAS+DELMAS
19800 PVIRTP(1) = PHEP(5,JM1)**2
19801 ELSE
19802 PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19803 PVIRTP(1) = 0.D0
19804 ENDIF
19805 IF(IDHEP(JM2).EQ.22) THEN
19806 PMASSP(2) = RHOMAS+DELMAS
19807 PVIRTP(2) = PHEP(5,JM2)**2
19808 ELSE
19809 PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19810 PVIRTP(2) = 0.D0
19811 ENDIF
19812
19813C calculate c.m. energy and check kinematics
19814 PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19815 PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19816 PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19817 PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19818 SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19819
19820 IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19821 WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19822 & 'energy smaller than two-particle threshold (event rejected)'
19823 CALL PHO_PREVNT(1)
19824 IREJ = 5
19825 GOTO 150
19826 ENDIF
19827 ECMP = SQRT(SS)
19828
19829 IF(IDEB(23).GE.5) THEN
19830 WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19831 & 'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19832 IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19833 ENDIF
19834
19835C Lorentz transformation into c.m. system
19836 DO 10 I=1,4
19837 GAMBEP(I) = PC(I)/ECMP
19838 10 CONTINUE
19839 CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19840 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19841 & PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19842C rotation angle: particle 1 moves along +z
19843 CODP = PC(3)/PTOT1
19844 SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19845 COFP = 1.D0
19846 SIFP = 0.D0
19847 IF(PTOT1*SIDP.GT.1.D-5) THEN
19848 COFP = PC(1)/(SIDP*PTOT1)
19849 SIFP = PC(2)/(SIDP*PTOT1)
19850 ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19851 COFP = COFP/ANORF
19852 SIFP = SIFP/ANORF
19853 ENDIF
19854C get CM momentum
19855 XM12 = PMASSP(1)**2
19856 XM22 = PMASSP(2)**2
19857 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19858
19859C find particle combination
19860 II = 0
19861 IF(IDPDG2.EQ.IFPAP(2)) THEN
19862 IF(IDPDG1.EQ.IFPAP(1)) II = 1
19863 ELSE IF(IDPDG2.EQ.990) THEN
19864 IF(IDPDG1.EQ.IFPAP(1)) THEN
19865 II = 2
19866 ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19867 II = 3
19868 ELSE IF(IDPDG1.EQ.990) THEN
19869 II = 4
19870 ENDIF
19871 ENDIF
19872 IF(II.EQ.0) THEN
19873 IF(ISWMDL(14).GT.0) THEN
19874 II = 1
19875 ELSE
19876 WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19877 & 'invalid particle combination:',IDPDG1,IDPDG2
19878 CALL PHO_ABORT
19879 ENDIF
19880 ENDIF
19881
19882C select parton distribution functions from tables
19883 IF((MHPOM+MHDIR).GT.0) THEN
19884 CALL PHO_ACTPDF(IDPDG1,1)
19885 CALL PHO_ACTPDF(IDPDG2,2)
19886C initialize alpha_s calculation
19887 DUMMY = PHO_ALPHAS(0.D0,-4)
19888 ENDIF
19889
19890C interpolate hard cross sections and rejection weights
19891 CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19892 & -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19893
19894 NTRY = 10
19895
19896C position of first particle added to /POEVT2/
19897 NLOR1 = NHEP+1
19898
19899C ---------------- direct processes -----------------
19900
19901 IF(MHDIR.EQ.1) THEN
19902 CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19903 IF(IREJ.EQ.50) RETURN
19904 IF(IREJ.NE.0) GOTO 150
19905C write comments to /POEVT1/
19906 CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19907 & X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19908 & IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19909 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19910 & PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19911 & ICA1,ICA2,IPOS,1)
19912 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19913 & PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19914 & ICA1,ICA2,IPOS,1)
19915 CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19916 & PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19917 & IPOS1,1)
19918 CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19919 & PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19920 & IPOS2,1)
19921
19922C soft spectator partons
19923 ICA1 = 0
19924 ICA2 = 0
19925 ICB1 = 0
19926 ICB2 = 0
19927 IPDF1 = 0
19928 IPDF2 = 0
19929
19930C single resolved: QCD compton scattering
19931C ------------------------------
19932 IF(NPROHD(1).EQ.10) THEN
19933C register hadron remnant
19934 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19935 IPDF2 = 1000*IGRP(2)+ISET(2)
19936 ELSE IF(NPROHD(1).EQ.12) THEN
19937C register hadron remnant
19938 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19939 IPDF1 = 1000*IGRP(1)+ISET(1)
19940
19941C single resolved: photon gluon fusion
19942C ---------------------------
19943 ELSE IF(NPROHD(1).EQ.11) THEN
19944C register hadron remnant
19945 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19946 IPDF2 = 1000*IGRP(2)+ISET(2)
19947 ELSE IF(NPROHD(1).EQ.13) THEN
19948C register hadron remnant
19949 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19950 IPDF1 = 1000*IGRP(1)+ISET(1)
19951
19952C direct process (no remnant)
19953C ----------------------------
19954 ELSE IF(NPROHD(1).EQ.14) THEN
19955
19956 ENDIF
19957
19958C write final high-pt partons to POEVT1
19959 IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19960 ICI(1,1) = ICA1
19961 ICI(1,2) = ICA2
19962 ICI(2,1) = ICB1
19963 ICI(2,2) = ICB2
19964 I = 1
19965 IFLA(1) = NINHD(I,1)
19966 IFLA(2) = NINHD(I,2)
19967C initial state radiation
19968 DO 130 K=1,2
19969 DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19970 KK = 1
19971 137 CONTINUE
19972 IFLB = IFLISR(K,IPA)
19973 IF(ABS(IFLB).LE.6) THEN
19974C partons
19975 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19976 IF(IFLB.EQ.0) THEN
19977 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19978 & ICI(K,1),ICI(K,2),3)
19979 ELSE IF(IFLB.GT.0) THEN
19980 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19981 & ICI(K,1),ICI(K,2),4)
19982 ELSE
19983 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19984 & IC1,IC2,4)
19985 ENDIF
19986 ELSE
19987 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19988 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19989 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19990 KK = KK+1
19991 GOTO 137
19992 ENDIF
19993 ENDIF
19994 IF(IFLB.EQ.0) THEN
19995 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19996 & IC1,IC2,2)
19997 ELSE
19998 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19999 & ICI(K,1),ICI(K,2),2)
20000 ENDIF
20001 ENDIF
20002 IIFL = IPHO_CNV1(IFLB)
20003
20004 IFLA(K) = IFLA(K)-IFLB
20005 IST = -1
20006 ELSE
20007C other particle
20008 IIFL = IFLB
20009 IC1 = 0
20010 IC2 = 0
20011 IST = 1
20012 ENDIF
20013 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20014 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
20015 & IGEN,IC1,IC2,IPOS,1)
20016 135 CONTINUE
20017 130 CONTINUE
20018 ICOLOR(1,IPOS1-2) = ICI(1,1)
20019 ICOLOR(2,IPOS1-2) = ICI(1,2)
20020 ICOLOR(1,IPOS1-1) = ICI(2,1)
20021 ICOLOR(2,IPOS1-1) = ICI(2,2)
20022 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20023 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20024 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
20025 ICOLOR(1,IPOS1) = ICI(1,1)
20026 ICOLOR(2,IPOS1) = ICI(1,2)
20027 ICOLOR(1,IPOS2) = ICI(2,1)
20028 ICOLOR(2,IPOS2) = ICI(2,2)
20029 DO 140 K=1,2
20030 IPA = IPOISR(K,1,I)
20031 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20032 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20033 & PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20034 140 CONTINUE
20035 ELSE
20036 ICOLOR(1,IPOS1-2) = ICA1
20037 ICOLOR(2,IPOS1-2) = ICA2
20038 ICOLOR(1,IPOS1-1) = ICB1
20039 ICOLOR(2,IPOS1-1) = ICB2
20040 CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
20041 & NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
20042 & NOUTHD(1,2),ICB1,ICB2)
20043 ICOLOR(1,IPOS1) = ICA1
20044 ICOLOR(2,IPOS1) = ICA2
20045 ICOLOR(1,IPOS2) = ICB1
20046 ICOLOR(2,IPOS2) = ICB2
20047 I = -1
20048 IF(ABS(NOUTHD(1,1)).GT.12) I = 1
20049 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
20050 & PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
20051 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
20052 & PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
20053 ENDIF
20054
20055C assign soft pt to spectators
20056 IF(ISWMDL(18).EQ.0) THEN
20057 IPOS2 = IPOS2-1
20058 CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
20059 IF(IREJ.NE.0) THEN
20060 IFAIL(26) = IFAIL(26) + 1
20061 GOTO 150
20062 ENDIF
20063
20064 ENDIF
20065
20066C ----------------- resolved processes -------------------
20067
20068C single Reggeon exchange
20069C ----------------------------
20070 ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
20071C flavours
20072 CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
20073 IF(IREJ.NE.0) THEN
20074 IFAIL(24) = IFAIL(24)+1
20075 GOTO 150
20076 ENDIF
20077
20078C colors
20079 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
20080 IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
20081 & .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
20082 CALL PHO_SWAPI(ICA1,ICB1)
20083 ENDIF
20084 ECMH = ECMP/2.D0
20085
20086C registration
20087
20088C DPMJET call with special projectile / target
20089**sr leading tab removed
20090 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
20091**
20092 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
20093 & ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
20094 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
20095 & ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
20096C default treatment
20097 ELSE
20098 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
20099 & -1,IGEN,ICA1,0,IPOS1,1)
20100 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
20101 & -1,IGEN,ICB1,0,IPOS2,1)
20102 ENDIF
20103
20104C soft pt assignment
20105 IF(ISWMDL(18).EQ.0) THEN
20106 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20107 IF(IREJ.NE.0) THEN
20108 IFAIL(25) = IFAIL(25) + 1
20109 GOTO 150
20110 ENDIF
20111 ENDIF
20112C
20113C multi Reggeon / Pomeron exchange
20114C----------------------------------------
20115 ELSE
20116C parton configuration
20117
20118 CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
20119 & MHPAR1,MHPAR2,IREJ)
20120
20121 IF(IREJ.EQ.50) RETURN
20122 IF(IREJ.NE.0) GOTO 150
20123
20124C register particles
20125 IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
20126 & 'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
20127 & MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
20128
20129C register soft partons
20130 IF(IVAL1.NE.0) THEN
20131 IF(IVAL1.LT.0) THEN
20132 IND1 = 3
20133 IVAL1=-IVAL1
20134 ELSE
20135 IND1 = 2
20136 ENDIF
20137 ELSE IF(MSPOM.EQ.0) THEN
20138 IND1 = 4
20139 ELSE
20140 IND1 = 1
20141 ENDIF
20142 IF(IVAL2.NE.0) THEN
20143 IF(IVAL2.LT.0) THEN
20144 IND2 = 3
20145 IVAL2=-IVAL2
20146 ELSE
20147 IND2 = 2
20148 ENDIF
20149 ELSE IF(MSPOM.EQ.0) THEN
20150 IND2 = 4
20151 ELSE
20152 IND2 = 1
20153 ENDIF
20154
20155 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
20156 & 'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
20157
20158C soft Pomeron final states
20159C -----------------------------------
20160 K = MSPOM+MHPOM+MSREG
20161 DO 50 I=1,MSPOM
20162
20163 CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
20164 IF(IREJ.NE.0) THEN
20165 IFAIL(8) = IFAIL(8) + 1
20166 GOTO 150
20167 ENDIF
20168C
20169 50 CONTINUE
20170
20171C soft Reggeon final states
20172C -----------------------------------------
20173 DO 75 I=1,MSREG
20174C flavours
20175 CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
20176 IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
20177 CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
20178 ELSE
20179 CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
20180 ENDIF
20181
20182C colors
20183 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
20184 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
20185 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
20186 & CALL PHO_SWAPI(ICA1,ICB1)
20187C registration
20188 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
20189 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
20190 & I,IGEN,ICA1,ICA2,IPOS1,1)
20191 IND1 = IND1+1
20192 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
20193 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
20194 & I,IGEN,ICB1,ICB2,IPOS2,1)
20195 IND2 = IND2+1
20196
20197 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
20198 & 'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
20199 & IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
20200
20201C soft pt assignment
20202 IF(ISWMDL(18).EQ.0) THEN
20203 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20204 IF(IREJ.NE.0) THEN
20205 IFAIL(25) = IFAIL(25) + 1
20206 GOTO 150
20207 ENDIF
20208 ENDIF
20209
20210 75 CONTINUE
20211
20212C hard Pomeron final states
20213C ------------------------------------
20214 IND1 = MSPAR1
20215 IND2 = MSPAR2
20216
20217 DO 100 L=1,MHPOM
20218 I = LSIDX(L)
20219
20220 IFLI1 = IPHO_CNV1(N0INHD(I,1))
20221 IFLI2 = IPHO_CNV1(N0INHD(I,2))
20222 IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20223 IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20224
20225C write comments to /POEVT1/
20226 CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20227 & X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20228 & IFLO1,IFLO2,IPOS,1)
20229 I1 = 8*I-7
20230 IPDF = 1000*IGRP(1)+ISET(1)
20231 CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20232 & PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20233 & ICA1,ICA2,IPOS,1)
20234 IPDF = 1000*IGRP(2)+ISET(2)
20235 CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20236 & PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20237 & ICB1,ICB2,IPOS,1)
20238 I1 = 8*I-3
20239 IPDF = 1000*IGRP(1)+ISET(1)
20240 CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20241 & PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20242 & ICA1,ICA2,IPOS1,1)
20243 IPDF = 1000*IGRP(2)+ISET(2)
20244 CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20245 & PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20246 & ICB1,ICB2,IPOS2,1)
20247
20248C spectator partons belonging to hard interaction
20249 IF(IVAL1.EQ.I) THEN
20250 IVQ = 1
20251 IND = 1
20252 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20253 IVQ = 0
20254 IND = 1
20255 ELSE
20256 IVQ = -1
20257 IND = IND1
20258 ENDIF
20259 CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20260 IF(IVQ.LT.0) IND1 = IND1-IUSED
20261 IF(IVAL2.EQ.I) THEN
20262 IVQ = 1
20263 IND = 1
20264 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20265 IVQ = 0
20266 IND = 1
20267 ELSE
20268 IVQ = -1
20269 IND = IND2
20270 ENDIF
20271 CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20272 IF(IVQ.LT.0) IND2 = IND2-IUSED
20273C
20274C register hard scattered partons
20275 IF((ISWMDL(8).GE.2)
20276 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20277 ICI(1,1) = ICA1
20278 ICI(1,2) = ICA2
20279 ICI(2,1) = ICB1
20280 ICI(2,2) = ICB2
20281 IFLA(1) = NINHD(I,1)
20282 IFLA(2) = NINHD(I,2)
20283C initial state radiation
20284 DO 230 K=1,2
20285 DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20286 KK = 1
20287 237 CONTINUE
20288 IFLB = IFLISR(K,IPA)
20289 IF(ABS(IFLB).LE.6) THEN
20290C partons
20291 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20292 IF(IFLB.EQ.0) THEN
20293 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20294 & ICI(K,1),ICI(K,2),3)
20295 ELSE IF(IFLB.GT.0) THEN
20296 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20297 & ICI(K,1),ICI(K,2),4)
20298 ELSE
20299 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20300 & ICI(K,2),IC1,IC2,4)
20301 ENDIF
20302 ELSE
20303 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20304 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20305 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20306 KK = KK+1
20307 GOTO 237
20308 ENDIF
20309 ENDIF
20310 IF(IFLB.EQ.0) THEN
20311 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20312 & ICI(K,2),IC1,IC2,2)
20313 ELSE
20314 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20315 & ICI(K,1),ICI(K,2),2)
20316 ENDIF
20317 ENDIF
20318 IIFL = IPHO_CNV1(IFLB)
20319
20320 IFLA(K) = IFLA(K)-IFLB
20321 IST = -1
20322 ELSE
20323C other particles
20324 IIFL = IFLB
20325 IC1 = 0
20326 IC2 = 0
20327 IST = 1
20328 ENDIF
20329 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20330 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20331 & L*100+K,IGEN,IC1,IC2,IPOS,1)
20332 235 CONTINUE
20333 230 CONTINUE
20334 ICOLOR(1,IPOS1-2) = ICI(1,1)
20335 ICOLOR(2,IPOS1-2) = ICI(1,2)
20336 ICOLOR(1,IPOS1-1) = ICI(2,1)
20337 ICOLOR(2,IPOS1-1) = ICI(2,2)
20338 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20339 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20340 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
20341 ICOLOR(1,IPOS1) = ICI(1,1)
20342 ICOLOR(2,IPOS1) = ICI(1,2)
20343 ICOLOR(1,IPOS2) = ICI(2,1)
20344 ICOLOR(2,IPOS2) = ICI(2,2)
20345 DO 240 K=1,2
20346 IPA = IPOISR(K,1,I)
20347 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20348 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20349 & PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20350 240 CONTINUE
20351 ELSE
20352 ICOLOR(1,IPOS1-2) = ICA1
20353 ICOLOR(2,IPOS1-2) = ICA2
20354 ICOLOR(1,IPOS1-1) = ICB1
20355 ICOLOR(2,IPOS1-1) = ICB2
20356 CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20357 & NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20358 & NOUTHD(I,2),ICB1,ICB2)
20359 ICOLOR(1,IPOS1) = ICA1
20360 ICOLOR(2,IPOS1) = ICA2
20361 ICOLOR(1,IPOS2) = ICB1
20362 ICOLOR(2,IPOS2) = ICB2
20363 I1 = 8*I-3
20364 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20365 & PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20366 & ICA1,ICA2,IPOS,1)
20367 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20368 & PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20369 & ICB1,ICB2,IPOS,1)
20370 ENDIF
20371 100 CONTINUE
20372C end of resolved parton registration
20373 ENDIF
20374
20375 IF(MHDIR+MHPOM.GT.0) THEN
20376
20377 IF(ISWMDL(29).GE.1) THEN
20378C primordial kt of hard scattering
20379 CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20380 IF(IREJ.NE.0) THEN
20381 IFAIL(27) = IFAIL(27)+1
20382 GOTO 150
20383 ENDIF
20384 ELSE IF(ISWMDL(24).GE.0) THEN
20385C give "soft" pt only to soft (spectator) partons in hard processes
20386 CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20387 IF(IREJ.NE.0) THEN
20388 IFAIL(26) = IFAIL(26)+1
20389 GOTO 150
20390 ENDIF
20391 ENDIF
20392
20393 ENDIF
20394
20395C give "soft" pt to partons in soft Pomerons
20396 IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20397 CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20398 IF(IREJ.NE.0) THEN
20399 IFAIL(25) = IFAIL(25) + 1
20400 GOTO 150
20401 ENDIF
20402 ENDIF
20403
20404C boost back to lab frame
20405 CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20406 & GAMBEP(1),GAMBEP(2),GAMBEP(3))
20407 RETURN
20408
20409C rejection treatment
20410 150 CONTINUE
20411 IFAIL(2) = IFAIL(2)+1
20412C reset counters
20413 KSPOM = KSPOMS
20414 KHPOM = KHPOMS
20415 KHDIR = KHDIRS
20416 KSREG = KSREGS
20417C reset mother-daugther relations
20418 JDAHEP(1,JM1) = 0
20419 JDAHEP(2,JM1) = 0
20420 JDAHEP(1,JM2) = 0
20421 JDAHEP(2,JM2) = 0
20422 ISTHEP(JM1) = 1
20423 ISTHEP(JM2) = 1
20424 IPOIX1 = IPOIS1
20425 IPOIX2 = IPOIS2
20426 NHEP = NHEPS
20427C debug
20428 IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20429 & 'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20430 & MSPOM,MHPOM,MSREG,MHDIR
20431 RETURN
20432
20433 END
20434
20435*$ CREATE PHO_HARCOL.FOR
20436*COPY PHO_HARCOL
20437CDECK ID>, PHO_HARCOL
20438 SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20439 & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20440C*********************************************************************
20441C
20442C calculate color flow for hard resolved process
20443C
20444C input: IP1..4 flavour of partons (PDG convention)
20445C V parton subprocess Mandelstam variable V = t/s
20446C (lightcone momenta assumed)
20447C ICA,ICB color labels
20448C MSPR process number
20449C -1 initialization of statistics
20450C -2 output of statistics
20451C
20452C output: ICC,ICD color label of final partons
20453C
20454C (it is possible to use the same variables for in and output)
20455C
20456C**********************************************************************
20457 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20458 SAVE
20459
20460C input/output channels
20461 INTEGER LI,LO
20462 COMMON /POINOU/ LI,LO
20463C event debugging information
20464 INTEGER NMAXD
20465 PARAMETER (NMAXD=100)
20466 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20467 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20468 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20469 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20470C model switches and parameters
20471 CHARACTER*8 MDLNA
20472 INTEGER ISWMDL,IPAMDL
20473 DOUBLE PRECISION PARMDL
20474 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20475C names of hard scattering processes
20476 INTEGER Max_pro_1
20477 PARAMETER ( Max_pro_1 = 16 )
20478 CHARACTER*18 PROC
20479 COMMON /POHPRO/ PROC(0:Max_pro_1)
20480
20481 DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20482
20483C initialization
20484 IF(MSPR.EQ.-1) THEN
20485 DO 200 I=1,8
20486 DO 210 K=1,5
20487 ICONF(I,K) = 0
20488 210 CONTINUE
20489 IRECN(I,1) = 0
20490 IRECN(I,2) = 0
20491 200 CONTINUE
20492 RETURN
20493C output of statistics
20494 ELSE IF(MSPR.EQ.-2) THEN
20495 IF(IDEB(26).LT.1) RETURN
20496 WRITE(LO,'(/1X,A,/1X,A)')
20497 & 'PHO_HARCOL: sampled color configurations',
20498 & '----------------------------------------'
20499 WRITE(LO,'(6X,A,15X,A)')
20500 & 'diagram color configurations (1-4)','sum'
20501 DO 300 I=1,8
20502 DO 310 K=1,4
20503 ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20504 310 CONTINUE
20505 WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20506 300 CONTINUE
20507 IF(ISWMDL(11).GE.2) THEN
20508 WRITE(LO,'(/6X,A)')
20509 & 'diagram with / without color re-connection'
20510 DO 320 I=1,8
20511 WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20512 320 CONTINUE
20513 ENDIF
20514 RETURN
20515 ENDIF
20516C
20517C gluons: first color positive, quarks second color zero
20518 IF(IP1.EQ.0) THEN
20519 IF(ICA1.LT.0) THEN
20520 I = ICA2
20521 ICA2 = ICA1
20522 ICA1 = I
20523 ENDIF
20524 ELSE
20525 ICA2 = 0
20526 ENDIF
20527 IF(IP2.EQ.0) THEN
20528 IF(ICB1.LT.0) THEN
20529 I = ICB2
20530 ICB2 = ICB1
20531 ICB1 = I
20532 ENDIF
20533 ELSE
20534 ICB2 = 0
20535 ENDIF
20536 IC2 = 0
20537 IC4 = 0
20538C debug output
20539 IF(IDEB(26).GE.15)
20540 & WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20541 & 'PHO_HARCOL: process',MSPR,
20542 & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20543C
20544 IRC = 0
20545 IF(IPAMDL(21).EQ.1) THEN
20546C
20547C soft color re-connection option
20548C
20549 IF(MSPR.EQ.1) THEN
20550C hard g g final state, only g g --> g g
20551 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20552 IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20553 IC1 = ICA1
20554 IC2 = ICA2
20555 IC3 = ICB1
20556 IC4 = ICB2
20557 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20558 IRC = 1
20559 GOTO 100
20560 ENDIF
20561 ENDIF
20562 ELSE IF(MSPR.EQ.3) THEN
20563C hard q g final state
20564 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20565 IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20566 IC1 = ICA1
20567 IC2 = ICA2
20568 IC3 = ICB1
20569 IC4 = ICB2
20570 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20571 IRC = 1
20572 GOTO 100
20573 ENDIF
20574 ENDIF
20575 ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20576C hard q q final state
20577 IF(ICA1.NE.-ICB1) THEN
20578 IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20579 IC1 = ICA1
20580 IC2 = ICA2
20581 IC3 = ICB1
20582 IC4 = ICB2
20583 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20584 IRC = 1
20585 GOTO 100
20586 ENDIF
20587 ENDIF
20588 ENDIF
20589 IRECN(MSPR,2) = IRECN(MSPR,2)+1
20590 ENDIF
20591C
20592 IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20593C
20594C large Nc limit of all graphs
20595C
20596 IF(MSPR.EQ.1) THEN
20597C g g --> g g
20598 IF(DT_RNDM(V).GT.0.5D0) THEN
20599 IC1 = ICB1
20600 IC2 = ICA2
20601 IC3 = ICA1
20602 IC4 = ICB2
20603 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20604 ELSE
20605 IC1 = ICA1
20606 IC2 = ICB2
20607 IC3 = ICB1
20608 IC4 = ICA2
20609 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20610 ENDIF
20611 ELSE IF(MSPR.EQ.2) THEN
20612C q qb --> g g
20613 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20614 IF(ICA1.LT.0) THEN
20615 IC1 = I1
20616 IC2 = ICA1
20617 IC3 = ICB1
20618 IC4 = I2
20619 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20620 ELSE
20621 IC1 = ICA1
20622 IC2 = I2
20623 IC3 = I1
20624 IC4 = ICB1
20625 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20626 ENDIF
20627 ELSE IF(MSPR.EQ.3) THEN
20628C q g --> q g
20629 IF(DT_RNDM(V).LT.0.5D0) THEN
20630 IF(IP1+IP2.GT.0) THEN
20631 IC1 = ICB1
20632 IC2 = ICA2
20633 IC3 = ICA1
20634 IC4 = ICB2
20635 ELSE IF(IP1.LT.0) THEN
20636 IC1 = ICB2
20637 IC3 = ICB1
20638 IC4 = ICA1
20639 ELSE
20640 IC1 = ICA1
20641 IC2 = ICB1
20642 IC3 = ICA2
20643 ENDIF
20644 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20645 ELSE
20646 IF(IP1.GT.0) THEN
20647 CALL PHO_HARCOR(-ICA1,ICB2)
20648 IC1 = ICA1
20649 IC3 = ICB1
20650 IC4 = -ICA1
20651 ELSE IF(IP2.GT.0) THEN
20652 CALL PHO_HARCOR(-ICB1,ICA2)
20653 IC1 = ICA1
20654 IC2 = -ICB1
20655 IC3 = ICB1
20656 ELSE IF(IP1.LT.0) THEN
20657 CALL PHO_HARCOR(-ICA1,ICB1)
20658 IC1 = ICA1
20659 IC3 = -ICA1
20660 IC4 = ICB2
20661 ELSE IF(IP2.LT.0) THEN
20662 CALL PHO_HARCOR(-ICB1,ICA1)
20663 IC1 = -ICB1
20664 IC2 = ICA2
20665 IC3 = ICB1
20666 ENDIF
20667 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20668 ENDIF
20669 ELSE IF(MSPR.EQ.4) THEN
20670C g g --> q qb
20671 IC1 = ICA1
20672 IC3 = ICB2
20673 CALL PHO_HARCOR(-ICB1,ICA2)
20674 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20675 IF(IP3*IC1.LT.0) THEN
20676 I = IC1
20677 IC1 = IC3
20678 IC3 = I
20679 ENDIF
20680 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20681 ELSE IF(MSPR.EQ.5) THEN
20682C q qb --> q qb
20683 IF(DT_RNDM(V).LT.0.5D0) THEN
20684 IF(ICA1*IP3.LT.0) THEN
20685 IC1 = ICB1
20686 IC3 = ICA1
20687 ELSE
20688 IC1 = ICA1
20689 IC3 = ICB1
20690 ENDIF
20691 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20692 ELSE
20693 IF(ICA1*IP3.LT.0) THEN
20694 IC1 = -ICA1
20695 IC3 = ICA1
20696 ELSE
20697 IC1 = ICA1
20698 IC3 = -ICA1
20699 ENDIF
20700 CALL PHO_HARCOR(-ICA1,ICB1)
20701 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20702 ENDIF
20703 ELSE IF(MSPR.EQ.6) THEN
20704C q qb --> qp qbp
20705 IF(ICA1*IP3.LT.0) THEN
20706 IC1 = ICB1
20707 IC3 = ICA1
20708 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20709 ELSE
20710 IC1 = ICA1
20711 IC3 = ICB1
20712 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20713 ENDIF
20714 ELSE IF(MSPR.EQ.7) THEN
20715C q q --> q q
20716 IF(DT_RNDM(V).LT.0.5D0) THEN
20717 IC1 = ICA1
20718 IC3 = ICB1
20719 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20720 ELSE
20721 IC1 = ICB1
20722 IC3 = ICA1
20723 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20724 ENDIF
20725 ELSE IF(MSPR.EQ.8) THEN
20726C q qp --> q qp
20727 IF(IP1*IP2.GT.0) THEN
20728 IF(IP3.EQ.IP1) THEN
20729 IC1 = ICB1
20730 IC3 = ICA1
20731 ELSE
20732 IC1 = ICA1
20733 IC3 = ICB1
20734 ENDIF
20735 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20736 ELSE
20737 IF(ICA1*IP3.LT.0) THEN
20738 IC1 = -ICA1
20739 IC3 = ICA1
20740 ELSE
20741 IC1 = ICA1
20742 IC3 = -ICA1
20743 ENDIF
20744 CALL PHO_HARCOR(-ICA1,ICB1)
20745 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20746 ENDIF
20747 ELSE
20748C unknown process
20749 WRITE(LO,'(/1X,A,I3)')
20750 & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20751 CALL PHO_ABORT
20752 ENDIF
20753C
20754 ELSE
20755C
20756C color flow according to QCD leading order matrix element
20757C
20758 U = -(1.D0+V)
20759 IF(MSPR.EQ.1) THEN
20760C g g --> g g
20761 PC(1) = 1/V**2 +2.D0/V +3.D0 +2.D0*V +V**2
20762 PC(2) = 1/U**2 +2.D0/U +3.D0 +2.D0*U +U**2
20763 PC(3) = (V/U)**2+2.D0*(V/U)+3.D0 +2.D0*(U/V)+(U/V)**2
20764 XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20765 PCS = 0.D0
20766 DO 110 I=1,3
20767 PCS = PCS+PC(I)
20768 IF(XI.LT.PCS) GOTO 120
20769 110 CONTINUE
20770 120 CONTINUE
20771 IF(I.EQ.1) THEN
20772 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20773 IF(DT_RNDM(V).GT.0.5D0) THEN
20774 IC1 = I1
20775 IC2 = ICA2
20776 IC3 = ICB1
20777 IC4 = I2
20778 CALL PHO_HARCOR(-ICB2,ICA1)
20779 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20780 ELSE
20781 IC1 = ICA1
20782 IC2 = I2
20783 IC3 = I1
20784 IC4 = ICB2
20785 CALL PHO_HARCOR(-ICB1,ICA2)
20786 IF(ICB2.EQ.-ICB1) IC4 = ICA2
20787 ENDIF
20788 ELSE IF(I.EQ.2) THEN
20789 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20790 IF(DT_RNDM(U).GT.0.5D0) THEN
20791 IC1 = ICB1
20792 IC2 = I2
20793 IC3 = I1
20794 IC4 = ICA2
20795 CALL PHO_HARCOR(-ICB2,ICA1)
20796 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20797 ELSE
20798 IC1 = I1
20799 IC2 = ICB2
20800 IC3 = ICA1
20801 IC4 = I2
20802 CALL PHO_HARCOR(-ICB1,ICA2)
20803 IF(ICB2.EQ.-ICB1) IC2 = ICA2
20804 ENDIF
20805 ELSE
20806 IF(DT_RNDM(V).GT.0.5D0) THEN
20807 IC1 = ICB1
20808 IC2 = ICA2
20809 IC3 = ICA1
20810 IC4 = ICB2
20811 ELSE
20812 IC1 = ICA1
20813 IC2 = ICB2
20814 IC3 = ICB1
20815 IC4 = ICA2
20816 ENDIF
20817 ENDIF
20818 ICONF(MSPR,I) = ICONF(MSPR,I)+1
20819 ELSE IF(MSPR.EQ.2) THEN
20820C q qb --> g g
20821 PC(1) = U/V-2.D0*U**2
20822 PC(2) = V/U-2.D0*V**2
20823 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20824 XI = (PC(1)+PC(2))*DT_RNDM(U)
20825 IF(XI.LT.PC(1)) THEN
20826 IF(ICA1.GT.0) THEN
20827 IC1 = ICA1
20828 IC2 = I2
20829 IC3 = I1
20830 IC4 = ICB1
20831 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20832 ELSE
20833 IC1 = I1
20834 IC2 = ICA1
20835 IC3 = ICB1
20836 IC4 = I2
20837 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20838 ENDIF
20839 ELSE
20840 IF(ICA1.GT.0) THEN
20841 IC1 = I1
20842 IC2 = ICB1
20843 IC3 = ICA1
20844 IC4 = I2
20845 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20846 ELSE
20847 IC1 = ICB1
20848 IC2 = I2
20849 IC3 = I1
20850 IC4 = ICA1
20851 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20852 ENDIF
20853 ENDIF
20854 ELSE IF(MSPR.EQ.3) THEN
20855C q g --> q g
20856 PC(1) = 2.D0*(U/V)**2-U
20857 PC(2) = 2.D0/V**2-1.D0/U
20858 XI = (PC(1)+PC(2))*DT_RNDM(V)
20859 IF(XI.LT.PC(1)) THEN
20860 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20861 IF(IP1.GT.0) THEN
20862 IC1 = I1
20863 IC3 = ICB1
20864 IC4 = I2
20865 CALL PHO_HARCOR(-ICA1,ICB2)
20866 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20867 ELSE IF(IP1.LT.0) THEN
20868 IC1 = I2
20869 IC3 = I1
20870 IC4 = ICB2
20871 CALL PHO_HARCOR(-ICA1,ICB1)
20872 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20873 ELSE IF(IP2.GT.0) THEN
20874 IC1 = ICA1
20875 IC2 = I2
20876 IC3 = I1
20877 CALL PHO_HARCOR(-ICB1,ICA2)
20878 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20879 ELSE
20880 IC1 = I1
20881 IC2 = ICA2
20882 IC3 = I2
20883 CALL PHO_HARCOR(-ICB1,ICA1)
20884 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20885 ENDIF
20886 ELSE
20887 IF(IP1.GT.0) THEN
20888 IC1 = ICB1
20889 IC3 = ICA1
20890 IC4 = ICB2
20891 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20892 ELSE IF(IP1.LT.0) THEN
20893 IC1 = ICB2
20894 IC3 = ICB1
20895 IC4 = ICA1
20896 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20897 ELSE IF(IP2.GT.0) THEN
20898 IC1 = ICB1
20899 IC2 = ICA2
20900 IC3 = ICA1
20901 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20902 ELSE
20903 IC1 = ICA1
20904 IC2 = ICB1
20905 IC3 = ICA2
20906 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20907 ENDIF
20908 ENDIF
20909 ELSE IF(MSPR.EQ.4) THEN
20910C g g --> q qb
20911 PC(1) = U/V-2.D0*U**2
20912 PC(2) = V/U-2.D0*V**2
20913 XI = (PC(1)+PC(2))*DT_RNDM(U)
20914 IF(XI.LT.PC(1)) THEN
20915 IF(IP3.GT.0) THEN
20916 IC1 = ICA1
20917 IC3 = ICB2
20918 CALL PHO_HARCOR(-ICB1,ICA2)
20919 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20920 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20921 ELSE
20922 IC1 = ICA2
20923 IC3 = ICB1
20924 CALL PHO_HARCOR(-ICB2,ICA1)
20925 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20926 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20927 ENDIF
20928 ELSE
20929 IF(IP3.GT.0) THEN
20930 IC1 = ICB1
20931 IC3 = ICA2
20932 CALL PHO_HARCOR(-ICB2,ICA1)
20933 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20934 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20935 ELSE
20936 IC1 = ICB2
20937 IC3 = ICA1
20938 CALL PHO_HARCOR(-ICB1,ICA2)
20939 IF(ICB2.EQ.-ICB1) IC1 = ICA2
20940 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20941 ENDIF
20942 ENDIF
20943 ELSE IF(MSPR.EQ.5) THEN
20944C q qb --> q qb
20945 PC(1) = (1.D0+U**2)/V**2
20946 PC(2) = (V**2+U**2)
20947 XI = (PC(1)+PC(2))*DT_RNDM(V)
20948 IF(XI.LT.PC(1)) THEN
20949 CALL PHO_HARCOR(-ICB1,ICA1)
20950 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20951 IF(IP3.GT.0) THEN
20952 IC1 = I1
20953 IC3 = I2
20954 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20955 ELSE
20956 IC1 = I2
20957 IC3 = I1
20958 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20959 ENDIF
20960 ELSE
20961 IF(IP3.GT.0) THEN
20962 IC1 = MAX(ICA1,ICB1)
20963 IC3 = MIN(ICA1,ICB1)
20964 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20965 ELSE
20966 IC1 = MIN(ICA1,ICB1)
20967 IC3 = MAX(ICA1,ICB1)
20968 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20969 ENDIF
20970 ENDIF
20971 ELSE IF(MSPR.EQ.6) THEN
20972C q qb --> qp qpb
20973 IF(IP3.GT.0) THEN
20974 IC1 = MAX(ICA1,ICB1)
20975 IC3 = MIN(ICA1,ICB1)
20976 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20977 ELSE
20978 IC1 = MIN(ICA1,ICB1)
20979 IC3 = MAX(ICA1,ICB1)
20980 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20981 ENDIF
20982 ELSE IF(MSPR.EQ.7) THEN
20983C q q --> q q
20984 PC(1) = (1.D0+U**2)/V**2
20985 PC(2) = (1.D0+V**2)/U**2
20986 XI = (PC(1)+PC(2))*DT_RNDM(U)
20987 IF(XI.LT.PC(1)) THEN
20988 IC1 = ICB1
20989 IC3 = ICA1
20990 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20991 ELSE
20992 IC1 = ICA1
20993 IC3 = ICB1
20994 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20995 ENDIF
20996 ELSE IF(MSPR.EQ.8) THEN
20997C q qp --> q qp
20998 IF(IP1*IP2.LT.0) THEN
20999 CALL PHO_HARCOR(-ICB1,ICA1)
21000 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
21001 IF(IP1.GT.0) THEN
21002 IC1 = I1
21003 IC3 = I2
21004 ICONF(MSPR,1) = ICONF(MSPR,1)+1
21005 ELSE
21006 IC1 = I2
21007 IC3 = I1
21008 ICONF(MSPR,2) = ICONF(MSPR,2)+1
21009 ENDIF
21010 ELSE
21011 IC1 = ICB1
21012 IC3 = ICA1
21013 ICONF(MSPR,3) = ICONF(MSPR,3)+1
21014 ENDIF
21015
21016 ELSE IF(MSPR.EQ.10) THEN
21017C gam q --> q g
21018 CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
21019 IF(IP3.EQ.0) THEN
21020 CALL PHO_SWAPI(IC1,IC3)
21021 CALL PHO_SWAPI(IC2,IC4)
21022 ENDIF
21023 ELSE IF(MSPR.EQ.11) THEN
21024C gam g --> q q
21025 IC1 = ICB1
21026 IC3 = ICB2
21027 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
21028 ELSE IF(MSPR.EQ.12) THEN
21029C q gam --> q g
21030 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
21031 IF(IP3.EQ.0) THEN
21032 CALL PHO_SWAPI(IC1,IC3)
21033 CALL PHO_SWAPI(IC2,IC4)
21034 ENDIF
21035 ELSE IF(MSPR.EQ.13) THEN
21036C g gam --> q q
21037 IC1 = ICA1
21038 IC3 = ICA2
21039 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
21040 ELSE IF(MSPR.EQ.14) THEN
21041 IF(ABS(IP3).GT.12) THEN
21042 IC1 = 0
21043 IC3 = 0
21044 ELSE
21045 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
21046 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
21047 ENDIF
21048 ELSE
21049C unknown process
21050 WRITE(LO,'(/1X,A,I3)')
21051 & 'PHO_HARCOL:ERROR:invalid process number',MSPR
21052 CALL PHO_ABORT
21053 ENDIF
21054 ENDIF
21055C
21056 100 CONTINUE
21057C debug output
21058 IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
21059 & 'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
21060C color connection?
21061* IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
21062* & (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
21063* & .OR.(IC2.EQ.0))) THEN
21064C color exchange?
21065* IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
21066* & .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
21067* IF(IRC.NE.1) THEN
21068* WRITE(LO,'(1X,A,I10,I3)')
21069* & 'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
21070* WRITE(LO,'(5X,A,3I5,2X,3I5)')
21071* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
21072* WRITE(LO,'(5X,A,3I5,2X,3I5)')
21073* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
21074* ENDIF
21075* IRC = 0
21076* ENDIF
21077* ENDIF
21078* IF(IRC.EQ.1) THEN
21079* WRITE(LO,'(1X,A,I10,I3)')
21080* & 'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
21081* WRITE(LO,'(5X,A,3I5,2X,3I5)')
21082* & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
21083* WRITE(LO,'(5X,A,3I5,2X,3I5)')
21084* & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
21085* ENDIF
21086C
21087 ICC1 = IC1
21088 ICC2 = IC2
21089 ICD1 = IC3
21090 ICD2 = IC4
21091
21092 END
21093
21094*$ CREATE PHO_HARCOR.FOR
21095*COPY PHO_HARCOR
21096CDECK ID>, PHO_HARCOR
21097 SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
21098C***********************************************************************
21099C
21100C substituite color in /POEVT2/
21101C
21102C input: ICOLD old color
21103C ICNEW new color
21104C
21105C***********************************************************************
21106 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21107 SAVE
21108
21109C input/output channels
21110 INTEGER LI,LO
21111 COMMON /POINOU/ LI,LO
21112
21113C standard particle data interface
21114 INTEGER NMXHEP
21115
21116 PARAMETER (NMXHEP=4000)
21117
21118 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21119 DOUBLE PRECISION PHEP,VHEP
21120 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21121 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21122 & VHEP(4,NMXHEP)
21123C extension to standard particle data interface (PHOJET specific)
21124 INTEGER IMPART,IPHIST,ICOLOR
21125 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21126
21127 DO 100 I=NHEP,3,-1
21128 IF(ISTHEP(I).EQ.-1) THEN
21129 IF(ICOLOR(1,I).EQ.ICOLD) THEN
21130 ICOLOR(1,I) = ICNEW
21131 RETURN
21132 ELSE IF(IDHEP(I).EQ.21) THEN
21133 IF(ICOLOR(2,I).EQ.ICOLD) THEN
21134 ICOLOR(2,I) = ICNEW
21135 RETURN
21136 ENDIF
21137 ENDIF
21138* ELSE IF(ISTHEP(I).EQ.20) THEN
21139* IF(ICOLOR(1,I).EQ.-ICOLD) THEN
21140* write(LO,*) ' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
21141* ICOLOR(1,I) = -ICNEW
21142* RETURN
21143* ELSE IF(IDHEP(I).EQ.21) THEN
21144* IF(ICOLOR(2,I).EQ.-ICOLD) THEN
21145* write(LO,*) ' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
21146* ICOLOR(2,I) = -ICNEW
21147* RETURN
21148* ENDIF
21149* ENDIF
21150 ENDIF
21151 100 CONTINUE
21152 END
21153
21154*$ CREATE PHO_HARREM.FOR
21155*COPY PHO_HARREM
21156CDECK ID>, PHO_HARREM
21157 SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
21158 & IUSED,IREJ)
21159C***********************************************************************
21160C
21161C sample color structure for initial quark/gluon of hard scattering
21162C and write hadron remnant to /POEVT1/
21163C
21164C input: JM1,2 index of mother particle in POEVT1
21165C IGEN mother particle production process
21166C IHPOS hard pomeron number
21167C INDXH index of hard parton
21168C positive for labels 1
21169C negative for labels 2
21170C IVAL 1 hard valence parton
21171C 0 hard sea parton connected by color flow with
21172C valence quarks
21173C -1 hard sea parton independent off valence
21174C quarks
21175C INDXS index of soft partons needed
21176C
21177C output: IC1,IC2 color label of initial parton
21178C IUSED number of soft X values used
21179C IREJ rejection flag
21180C
21181C**********************************************************************
21182 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21183 SAVE
21184
21185 PARAMETER ( TINY = 1.D-10 )
21186
21187C input/output channels
21188 INTEGER LI,LO
21189 COMMON /POINOU/ LI,LO
21190C event debugging information
21191 INTEGER NMAXD
21192 PARAMETER (NMAXD=100)
21193 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21194 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21195 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21196 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21197C model switches and parameters
21198 CHARACTER*8 MDLNA
21199 INTEGER ISWMDL,IPAMDL
21200 DOUBLE PRECISION PARMDL
21201 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21202C data of c.m. system of Pomeron / Reggeon exchange
21203 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21204 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21205 & SIDP,CODP,SIFP,COFP
21206 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21207 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21208 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21209C obsolete cut-off information
21210 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21211 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21212C light-cone x fractions and c.m. momenta of soft cut string ends
21213 INTEGER MAXSOF
21214 PARAMETER ( MAXSOF = 50 )
21215 INTEGER IJSI2,IJSI1
21216 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21217 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21218 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21219 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21220C hard scattering data
21221 INTEGER MSCAHD
21222 PARAMETER ( MSCAHD = 50 )
21223 INTEGER LSCAHD,LSC1HD,LSIDX,
21224 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21225 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21226 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21227 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21228 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21229 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21230 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21231 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21232 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21233
21234C standard particle data interface
21235 INTEGER NMXHEP
21236
21237 PARAMETER (NMXHEP=4000)
21238
21239 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21240 DOUBLE PRECISION PHEP,VHEP
21241 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21242 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21243 & VHEP(4,NMXHEP)
21244C extension to standard particle data interface (PHOJET specific)
21245 INTEGER IMPART,IPHIST,ICOLOR
21246 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21247
21248C internal rejection counters
21249 INTEGER NMXJ
21250 PARAMETER (NMXJ=60)
21251 CHARACTER*10 REJTIT
21252 INTEGER IFAIL
21253 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21254
21255 IREJ = 0
21256
21257 INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21258
21259 IF(INDXH.GT.0) THEN
21260 IJH = IPHO_CNV1(NINHD(INDXH,1))
21261 ELSE
21262 IJH = IPHO_CNV1(NINHD(-INDXH,2))
21263 ENDIF
21264C direct process (photon or pomeron)
21265 IUSED = 0
21266 IC1 = 0
21267 IC2 = 0
21268 IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21269
21270 IHP = 100*ABS(IHPOS)
21271 IVSW = 1
21272***************************************
21273* IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21274***************************************
21275
21276 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21277 & 'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21278 & JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21279
21280C quark
21281C****************************************************************
21282
21283 IF(IJH.NE.21) THEN
21284
21285C valence quark engaged in hard scattering
21286 IF(IVAL.EQ.1) THEN
21287 CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21288 IF(IREJ.NE.0) THEN
21289 WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21290 & 'invalid valence flavour requested JM,IFLA',JM1,IJH
21291 return
21292 ENDIF
21293 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21294 IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21295 & .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21296 I = ICA1
21297 ICA1 = ICB1
21298 ICB1 = I
21299 ENDIF
21300C remnant of hadron
21301 IF(INDXH.GT.0) THEN
21302 P1 = PSOFT1(1,INDXS)
21303 P2 = PSOFT1(2,INDXS)
21304 P3 = PSOFT1(3,INDXS)
21305 P4 = PSOFT1(4,INDXS)
21306 IJSI1(INDXS) = IREM
21307 ELSE
21308 P1 = PSOFT2(1,INDXS)
21309 P2 = PSOFT2(2,INDXS)
21310 P3 = PSOFT2(3,INDXS)
21311 P4 = PSOFT2(4,INDXS)
21312 IJSI2(INDXS) = IREM
21313 ENDIF
21314C registration
21315 CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21316 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21317 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21318 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21319 & IREM,IPOS,SIGN(INDXS,INDXH)
21320
21321 IUSED = 1
21322
21323C sea quark engaged in hard scattering, valence quarks treated
21324 ELSE IF(IVAL.EQ.0) THEN
21325 IF(INDXH.GT.0) THEN
21326 E1 = PSOFT1(4,INDXS)
21327 E2 = PSOFT1(4,INDXS+1)
21328 ELSE
21329 E1 = PSOFT2(4,INDXS)
21330 E2 = PSOFT2(4,INDXS+1)
21331 ENDIF
21332 CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21333 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21334 IF(DT_RNDM(P1).LT.0.5D0) THEN
21335 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21336 ELSE
21337 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21338 ENDIF
21339 IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21340 & .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21341 I = ICA1
21342 ICA1 = ICB1
21343 ICB1 = I
21344 ENDIF
21345 IF(INDXH.GT.0) THEN
21346 P1 = PSOFT1(1,INDXS)
21347 P2 = PSOFT1(2,INDXS)
21348 P3 = PSOFT1(3,INDXS)
21349 P4 = PSOFT1(4,INDXS)
21350 IJSI1(INDXS) = IVFL1
21351 ELSE
21352 P1 = PSOFT2(1,INDXS)
21353 P2 = PSOFT2(2,INDXS)
21354 P3 = PSOFT2(3,INDXS)
21355 P4 = PSOFT2(4,INDXS)
21356 IJSI2(INDXS) = IVFL1
21357 ENDIF
21358C registration
21359 CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21360 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21361 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21362 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21363 & IVFL1,IPOS,SIGN(INDXS,INDXH)
21364
21365C
21366 IF(INDXH.GT.0) THEN
21367 P1 = PSOFT1(1,INDXS+1)
21368 P2 = PSOFT1(2,INDXS+1)
21369 P3 = PSOFT1(3,INDXS+1)
21370 P4 = PSOFT1(4,INDXS+1)
21371 IJSI1(INDXS+1) = IVFL2
21372 ELSE
21373 P1 = PSOFT2(1,INDXS+1)
21374 P2 = PSOFT2(2,INDXS+1)
21375 P3 = PSOFT2(3,INDXS+1)
21376 P4 = PSOFT2(4,INDXS+1)
21377 IJSI2(INDXS+1) = IVFL2
21378 ENDIF
21379C registration
21380 CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21381 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21382 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21383 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21384 & IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21385
21386C
21387 IF(IJH.LT.0) THEN
21388 ICB1 = ICC2
21389 ICA1 = ICC1
21390 ELSE
21391 ICB1 = ICC1
21392 ICA1 = ICC2
21393 ENDIF
21394 IF(INDXH.GT.0) THEN
21395 P1 = PSOFT1(1,INDXS+2)
21396 P2 = PSOFT1(2,INDXS+2)
21397 P3 = PSOFT1(3,INDXS+2)
21398 P4 = PSOFT1(4,INDXS+2)
21399 IJSI1(INDXS+2) = -IJH
21400 ELSE
21401 P1 = PSOFT2(1,INDXS+2)
21402 P2 = PSOFT2(2,INDXS+2)
21403 P3 = PSOFT2(3,INDXS+2)
21404 P4 = PSOFT2(4,INDXS+2)
21405 IJSI2(INDXS+2) = -IJH
21406 ENDIF
21407C registration
21408 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21409 & IHP,IGEN,ICA1,0,IPOS,1)
21410 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21411 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21412 & -IJH,IPOS,SIGN(INDXS+2,INDXH)
21413 IUSED = 3
21414C
21415C sea quark engaged in hard scattering, valences treated separately
21416 ELSE IF(IVAL.EQ.-1) THEN
21417 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21418 IF(IJH.GT.0) THEN
21419 ICC1 = ICB1
21420 ICB1 = ICA1
21421 ICA1 = ICC1
21422 ENDIF
21423 IF(INDXH.GT.0) THEN
21424 P1 = PSOFT1(1,INDXS)
21425 P2 = PSOFT1(2,INDXS)
21426 P3 = PSOFT1(3,INDXS)
21427 P4 = PSOFT1(4,INDXS)
21428 IJSI1(INDXS) = -IJH
21429 ELSE
21430 P1 = PSOFT2(1,INDXS)
21431 P2 = PSOFT2(2,INDXS)
21432 P3 = PSOFT2(3,INDXS)
21433 P4 = PSOFT2(4,INDXS)
21434 IJSI2(INDXS) = -IJH
21435 ENDIF
21436C registration
21437 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21438 & IHP,IGEN,ICA1,0,IPOS,1)
21439 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21440 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21441 & -IJH,IPOS,SIGN(INDXS,INDXH)
21442
21443 IUSED = 1
21444 ELSE
21445 WRITE(LO,'(1X,A,2I5)')
21446 & 'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21447 & IVAL,IJH
21448 CALL PHO_ABORT
21449 ENDIF
21450C
21451 IC1 = ICB1
21452 IC2 = 0
21453C
21454C gluon
21455C****************************************************************
21456C
21457C gluon from valence quarks
21458 ELSE
21459 IF(IVAL.EQ.1) THEN
21460C purely gluonic pomeron remnant
21461 IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21462 IF(INDXH.GT.0) THEN
21463 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21464 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21465 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21466 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21467 IJSI1(INDXS) = 0
21468 ELSE
21469 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21470 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21471 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21472 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21473 IJSI2(INDXS) = 0
21474 ENDIF
21475 IFL1 = 21
21476 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21477 IF(DT_RNDM(P2).LT.0.5D0) THEN
21478 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21479 ELSE
21480 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21481 ENDIF
21482C registration
21483 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21484 & IHP,IGEN,ICA1,ICB1,IPOS,1)
21485 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21486 & 'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21487 & IFL1,IPOS,SIGN(INDXS,INDXH)
21488
21489 IUSED = 2
21490C valence quark remnant
21491 ELSE
21492 IF(INDXH.GT.0) THEN
21493 E1 = PSOFT1(4,INDXS)
21494 E2 = PSOFT1(4,INDXS+1)
21495 ELSE
21496 E1 = PSOFT2(4,INDXS)
21497 E2 = PSOFT2(4,INDXS+1)
21498 ENDIF
21499 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21500 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21501 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21502 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21503 I = ICA1
21504 ICA1 = ICB1
21505 ICB1 = I
21506 ENDIF
21507 IF(DT_RNDM(P2).LT.0.5D0) THEN
21508 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21509 ELSE
21510 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21511 ENDIF
21512C remnant of hadron
21513 IF(INDXH.GT.0) THEN
21514 P1 = PSOFT1(1,INDXS)
21515 P2 = PSOFT1(2,INDXS)
21516 P3 = PSOFT1(3,INDXS)
21517 P4 = PSOFT1(4,INDXS)
21518 IJSI1(INDXS) = IFL1
21519 ELSE
21520 P1 = PSOFT2(1,INDXS)
21521 P2 = PSOFT2(2,INDXS)
21522 P3 = PSOFT2(3,INDXS)
21523 P4 = PSOFT2(4,INDXS)
21524 IJSI2(INDXS) = IFL1
21525 ENDIF
21526C registration
21527 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21528 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21529 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21530 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21531 & IFL1,IPOS,SIGN(INDXS,INDXH)
21532
21533C
21534 IF(INDXH.GT.0) THEN
21535 P1 = PSOFT1(1,INDXS+1)
21536 P2 = PSOFT1(2,INDXS+1)
21537 P3 = PSOFT1(3,INDXS+1)
21538 P4 = PSOFT1(4,INDXS+1)
21539 IJSI1(INDXS+1) = IFL2
21540 ELSE
21541 P1 = PSOFT2(1,INDXS+1)
21542 P2 = PSOFT2(2,INDXS+1)
21543 P3 = PSOFT2(3,INDXS+1)
21544 P4 = PSOFT2(4,INDXS+1)
21545 IJSI2(INDXS+1) = IFL2
21546 ENDIF
21547C registration
21548 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21549 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21550 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21551 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21552 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21553
21554 IUSED = 2
21555 ENDIF
21556C
21557C gluon from sea quarks connected with valence quarks
21558 ELSE IF(IVAL.EQ.0) THEN
21559 IF(INDXH.GT.0) THEN
21560 E1 = PSOFT1(4,INDXS)
21561 E2 = PSOFT1(4,INDXS+1)
21562 ELSE
21563 E1 = PSOFT2(4,INDXS)
21564 E2 = PSOFT2(4,INDXS+1)
21565 ENDIF
21566 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21567 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21568 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21569 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21570 I = ICA1
21571 ICA1 = ICB1
21572 ICB1 = I
21573 ENDIF
21574 IF(DT_RNDM(P3).LT.0.5D0) THEN
21575 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21576 ELSE
21577 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21578 ENDIF
21579C remnant of hadron
21580 IF(INDXH.GT.0) THEN
21581 P1 = PSOFT1(1,INDXS)
21582 P2 = PSOFT1(2,INDXS)
21583 P3 = PSOFT1(3,INDXS)
21584 P4 = PSOFT1(4,INDXS)
21585 IJSI1(INDXS) = IFL1
21586 ELSE
21587 P1 = PSOFT2(1,INDXS)
21588 P2 = PSOFT2(2,INDXS)
21589 P3 = PSOFT2(3,INDXS)
21590 P4 = PSOFT2(4,INDXS)
21591 IJSI2(INDXS) = IFL1
21592 ENDIF
21593C registration
21594 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21595 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21596 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21597 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21598 & IFL1,IPOS,SIGN(INDXS,INDXH)
21599
21600C
21601 IF(INDXH.GT.0) THEN
21602 P1 = PSOFT1(1,INDXS+1)
21603 P2 = PSOFT1(2,INDXS+1)
21604 P3 = PSOFT1(3,INDXS+1)
21605 P4 = PSOFT1(4,INDXS+1)
21606 IJSI1(INDXS+1) = IFL2
21607 ELSE
21608 P1 = PSOFT2(1,INDXS+1)
21609 P2 = PSOFT2(2,INDXS+1)
21610 P3 = PSOFT2(3,INDXS+1)
21611 P4 = PSOFT2(4,INDXS+1)
21612 IJSI2(INDXS+1) = IFL2
21613 ENDIF
21614C registration
21615 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21616 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21617 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21618 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21619 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21620
21621 IF(IPAMDL(18).EQ.0) THEN
21622C sea quark pair
21623 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21624 IF(ICC1.GT.0) THEN
21625 IFL1 = ABS(IFL1)
21626 IFL2 = -IFL1
21627 ELSE
21628 IFL1 = -ABS(IFL1)
21629 IFL2 = -IFL1
21630 ENDIF
21631 IF(DT_RNDM(P4).LT.0.5D0) THEN
21632 ICB1 = ICC2
21633 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21634 ELSE
21635 ICA1 = ICC1
21636 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21637 ENDIF
21638 IF(INDXH.GT.0) THEN
21639 P1 = PSOFT1(1,INDXS+2)
21640 P2 = PSOFT1(2,INDXS+2)
21641 P3 = PSOFT1(3,INDXS+2)
21642 P4 = PSOFT1(4,INDXS+2)
21643 IJSI1(INDXS+2) = IFL1
21644 ELSE
21645 P1 = PSOFT2(1,INDXS+2)
21646 P2 = PSOFT2(2,INDXS+2)
21647 P3 = PSOFT2(3,INDXS+2)
21648 P4 = PSOFT2(4,INDXS+2)
21649 IJSI2(INDXS+2) = IFL1
21650 ENDIF
21651C registration
21652 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21653 & IHP,IGEN,ICA1,0,IPOS,1)
21654 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21655 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21656 & IFL1,IPOS,SIGN(INDXS+2,INDXH)
21657
21658C
21659 IF(INDXH.GT.0) THEN
21660 P1 = PSOFT1(1,INDXS+3)
21661 P2 = PSOFT1(2,INDXS+3)
21662 P3 = PSOFT1(3,INDXS+3)
21663 P4 = PSOFT1(4,INDXS+3)
21664 IJSI1(INDXS+3) = IFL2
21665 ELSE
21666 P1 = PSOFT2(1,INDXS+3)
21667 P2 = PSOFT2(2,INDXS+3)
21668 P3 = PSOFT2(3,INDXS+3)
21669 P4 = PSOFT2(4,INDXS+3)
21670 IJSI2(INDXS+3) = IFL2
21671 ENDIF
21672C registration
21673 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21674 & IHP,IGEN,ICB1,0,IPOS,1)
21675 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21676 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21677 & IFL2,IPOS,SIGN(INDXS+3,INDXH)
21678
21679 IUSED = 4
21680 ELSE
21681 IUSED = 2
21682 ENDIF
21683C
21684C gluon from independent sea quarks
21685 ELSE IF(IVAL.EQ.-1) THEN
21686 IF(IPAMDL(18).EQ.0) THEN
21687 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21688 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21689 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21690 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21691 I = ICA1
21692 ICA1 = ICB1
21693 ICB1 = I
21694 ENDIF
21695 IF(DT_RNDM(P1).LT.0.5D0) THEN
21696 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21697 ELSE
21698 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21699 ENDIF
21700C remainder of hadron
21701 IF(INDXH.GT.0) THEN
21702 P1 = PSOFT1(1,INDXS)
21703 P2 = PSOFT1(2,INDXS)
21704 P3 = PSOFT1(3,INDXS)
21705 P4 = PSOFT1(4,INDXS)
21706 IJSI1(INDXS) = IFL1
21707 ELSE
21708 P1 = PSOFT2(1,INDXS)
21709 P2 = PSOFT2(2,INDXS)
21710 P3 = PSOFT2(3,INDXS)
21711 P4 = PSOFT2(4,INDXS)
21712 IJSI2(INDXS) = IFL1
21713 ENDIF
21714C registration
21715 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21716 & IHP,IGEN,ICA1,ICA2,IPOS,1)
21717 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21718 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21719 & IFL1,IPOS,SIGN(INDXS,INDXH)
21720
21721C remnant of sea
21722 IF(INDXH.GT.0) THEN
21723 P1 = PSOFT1(1,INDXS-1)
21724 P2 = PSOFT1(2,INDXS-1)
21725 P3 = PSOFT1(3,INDXS-1)
21726 P4 = PSOFT1(4,INDXS-1)
21727 IJSI1(INDXS-1) = IFL2
21728 ELSE
21729 P1 = PSOFT2(1,INDXS-1)
21730 P2 = PSOFT2(2,INDXS-1)
21731 P3 = PSOFT2(3,INDXS-1)
21732 P4 = PSOFT2(4,INDXS-1)
21733 IJSI2(INDXS-1) = IFL2
21734 ENDIF
21735C registration
21736 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21737 & IHP,IGEN,ICB1,ICB2,IPOS,1)
21738 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21739 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21740 & IFL2,IPOS,SIGN(INDXS-1,INDXH)
21741
21742 IUSED = 2
21743 ELSE
21744 CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21745 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21746 & 'PHO_HARREM: no spectator added:(INDXS)',
21747 & SIGN(INDXS,INDXH)
21748 IUSED = 0
21749 ENDIF
21750C
21751 ELSE
21752 WRITE(LO,'(1X,A,2I5)')
21753 & 'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21754 & IVAL,IJH
21755 CALL PHO_ABORT
21756 ENDIF
21757 IC1 = ICC1
21758 IC2 = ICC2
21759 ENDIF
21760 END
21761
21762*$ CREATE PHO_HARDIR.FOR
21763*COPY PHO_HARDIR
21764CDECK ID>, PHO_HARDIR
21765 SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21766 & IREJ)
21767C**********************************************************************
21768C
21769C parton orientated formulation of direct scattering processes
21770C
21771C input:
21772C
21773C output: II particle combination (1..4)
21774C IVAL1,2 0 no valence quarks engaged
21775C 1 valence quarks engaged
21776C MSPAR1,2 number of realized soft partons
21777C MHPAR1,2 number of realized hard partons
21778C IREJ 1 failure
21779C 0 success
21780C
21781C**********************************************************************
21782 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21783 SAVE
21784
21785C input/output channels
21786 INTEGER LI,LO
21787 COMMON /POINOU/ LI,LO
21788C event debugging information
21789 INTEGER NMAXD
21790 PARAMETER (NMAXD=100)
21791 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21792 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21793 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21794 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21795C model switches and parameters
21796 CHARACTER*8 MDLNA
21797 INTEGER ISWMDL,IPAMDL
21798 DOUBLE PRECISION PARMDL
21799 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21800C hard scattering parameters used for most recent hard interaction
21801 INTEGER NFbeta,NF
21802 DOUBLE PRECISION ALQCD2,BQCD
21803 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21804C data of c.m. system of Pomeron / Reggeon exchange
21805 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21806 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21807 & SIDP,CODP,SIFP,COFP
21808 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21809 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21810 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21811C obsolete cut-off information
21812 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21813 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21814C hard cross sections and MC selection weights
21815 INTEGER Max_pro_2
21816 PARAMETER ( Max_pro_2 = 16 )
21817 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21818 & MH_acc_1,MH_acc_2
21819 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21820 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21821 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21822 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21823 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21824 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21825C data on most recent hard scattering
21826 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21827 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21828 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21829 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21830 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21831 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21832 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21833 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21834 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21835C light-cone x fractions and c.m. momenta of soft cut string ends
21836 INTEGER MAXSOF
21837 PARAMETER ( MAXSOF = 50 )
21838 INTEGER IJSI2,IJSI1
21839 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21840 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21841 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21842 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21843C hard scattering data
21844 INTEGER MSCAHD
21845 PARAMETER ( MSCAHD = 50 )
21846 INTEGER LSCAHD,LSC1HD,LSIDX,
21847 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21848 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21849 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21850 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21851 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21852 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21853 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21854 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21855 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21856C internal rejection counters
21857 INTEGER NMXJ
21858 PARAMETER (NMXJ=60)
21859 CHARACTER*10 REJTIT
21860 INTEGER IFAIL
21861 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21862
21863 DIMENSION P1(4),P2(4),PD1(-6:6)
21864
21865 PARAMETER ( TINY = 1.D-10 )
21866
21867 ITRY = 0
21868 NTRY = 10
21869 LSC1HD = 0
21870 LSIDX(1) = 1
21871
21872C check phase space
21873 IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21874 IFAIL(18) = IFAIL(18)+1
21875 IREJ = 50
21876 RETURN
21877 ENDIF
21878
21879 AS = (PARMDL(160+II)/ECMP)**2
21880 AH = (2.D0*PTWANT/ECMP)**2
21881
21882 ALNS = LOG(AS)
21883 ALNH = LOG(AH)
21884
21885 XMAX = MAX(TINY,1.D0-AS)
21886 Z1MAX = LOG(XMAX)
21887 Z1DIF = Z1MAX-ALNH
21888C
21889C main loop to select hard and soft parton kinematics
21890C -----------------------------------------------------
21891 120 CONTINUE
21892 IREJ = 0
21893 ITRY = ITRY+1
21894 LSC1HD = LSC1HD+1
21895 IF(ITRY.GT.1) THEN
21896 IFAIL(17) = IFAIL(17)+1
21897 IF(ITRY.GE.NTRY) THEN
21898 IREJ = 1
21899 GOTO 450
21900 ENDIF
21901 ENDIF
21902 LINE = 0
21903 LSCAHD = 0
21904 XSS1 = 0.D0
21905 XSS2 = 0.D0
21906 MSPAR1 = 0
21907 MSPAR2 = 0
21908
21909C select hard V,X
21910 CALL PHO_HARSCA(1,II)
21911 XSS1 = XSS1+X1
21912 XSS2 = XSS2+X2
21913C debug output
21914 IF(IDEB(25).GE.20) THEN
21915 WRITE(LO,'(1X,A,2E12.4,2I5)')
21916 & 'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21917 & AS,XMAX,MSPR,ITRY
21918 WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2 SUM X1,2',
21919 & X1,X2,XSS1,XSS2
21920 ENDIF
21921
21922 IF(MSPR.LE.11) THEN
21923 IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21924 ELSE IF(MSPR.LE.13) THEN
21925 IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21926 ENDIF
21927
21928C fill /POHSLT/
21929 LSCAHD = 1
21930 LSIDX(1) = 1
21931 XHD(1,1) = X1
21932 XHD(1,2) = X2
21933 X0HD(1,1) = X1
21934 X0HD(1,2) = X2
21935 VHD(1) = V
21936 ETAHD(1,1) = ETAC
21937 ETAHD(1,2) = ETAD
21938 PTHD(1) = PT
21939 Q2SCA(1,1) = QQPD
21940 Q2SCA(1,2) = QQPD
21941 NPROHD(1) = MSPR
21942 NBRAHD(1,1)= IDPDG1
21943 NBRAHD(1,2)= IDPDG2
21944 DO 45 I=1,4
21945 PPH(I,1) = PHI1(I)
21946 PPH(I,2) = PHI2(I)
21947 PPH(4+I,1) = PHO1(I)
21948 PPH(4+I,2) = PHO2(I)
21949 45 CONTINUE
21950C valence quarks
21951 IVAL1 = IV1
21952 IVAL2 = IV2
21953 PDFVA(1,1) = 0.D0
21954 PDFVA(1,2) = 0.D0
21955C parton flavours
21956 IF(MSPR.LE.11) THEN
21957 NINHD(1,1) = IDPDG1
21958 NINHD(1,2) = IB
21959 PDFVA(1,2) = PDF2(IB)
21960 KHDIR = 1
21961 ELSE IF(MSPR.LE.13) THEN
21962 NINHD(1,1) = IA
21963 PDFVA(1,1) = PDF1(IA)
21964 NINHD(1,2) = IDPDG2
21965 KHDIR = 2
21966 ELSE
21967 NINHD(1,1) = IDPDG1
21968 NINHD(1,2) = IDPDG2
21969 KHDIR = 3
21970 ENDIF
21971 N0INHD(1,1) = NINHD(1,1)
21972 N0INHD(1,2) = NINHD(1,2)
21973 N0IVAL(1,1) = IVAL1
21974 N0IVAL(1,2) = IVAL2
21975 NOUTHD(1,1) = IC
21976 NOUTHD(1,2) = ID
21977
21978C reweight according to photon virtuality
21979 IF(MSPR.NE.14) THEN
21980 IF(IPAMDL(115).GE.1) THEN
21981 WGX = 1.D0
21982 IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21983 QQPD = Q2SCA(1,2)
21984 IF(IPAMDL(115).EQ.1) THEN
21985 IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21986 WGX = 0.D0
21987 ELSE
21988 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21989 & /LOG(QQPD/PARMDL(144))
21990 ENDIF
21991 IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21992 ELSE IF(IPAMDL(115).EQ.2) THEN
21993 CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21994 WGX = PD1(IB)/PDFVA(1,2)
21995 ENDIF
21996 ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21997 & .AND.(IDPDG1.EQ.22)) THEN
21998 QQPD = Q2SCA(1,1)
21999 IF(IPAMDL(115).EQ.1) THEN
22000 IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
22001 WGX = 0.D0
22002 ELSE
22003 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22004 & /LOG(QQPD/PARMDL(144))
22005 ENDIF
22006 IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
22007 ELSE IF(IPAMDL(115).EQ.2) THEN
22008 CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
22009 WGX = PD1(IA)/PDFVA(1,1)
22010 ENDIF
22011 ENDIF
22012
22013 IF(IDEB(25).GE.25)
22014 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
22015 & 're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22016 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
22017
22018 IF(WGX.LT.DT_RNDM(WGX)) THEN
22019 IREJ = 50
22020 RETURN
22021 ENDIF
22022
22023 IF(WGX.GT.1.01D0)
22024 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
22025 & 're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22026 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
22027
22028 ENDIF
22029 ENDIF
22030
22031C generate ISR
22032 IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
22033 IF(IPAMDL(109).EQ.1) THEN
22034 Q2H = PARMDL(93)*PT**2
22035 ELSE
22036 Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
22037 ENDIF
22038 XHMAX1 = 1.D0 - XSS1 - AS + XHD(1,1)
22039 XHMAX2 = 1.D0 - XSS2 - AS + XHD(1,2)
22040 DO 42 J=1,4
22041 P1(J) = PPH(4+J,1)
22042 P2(J) = PPH(4+J,2)
22043 42 CONTINUE
22044 CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
22045 & N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
22046 & XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
22047 XSS1 = XSS1+XISR1-XHD(1,1)
22048 XSS2 = XSS2+XISR2-XHD(1,2)
22049 NINHD(1,1) = IFL1
22050 NINHD(1,2) = IFL2
22051 XHD(1,1) = XISR1
22052 XHD(1,2) = XISR2
22053 ELSE
22054 IFL1 = NINHD(1,1)
22055 IFL2 = NINHD(1,2)
22056 ENDIF
22057 NIVAL(1,1) = IVAL1
22058 NIVAL(1,2) = IVAL2
22059
22060C add photon/hadron remnant
22061
22062C incoming gluon
22063 IF(IFL2.EQ.0) THEN
22064 XMAXX = 1.D0 - XSS2 - AS
22065 XMAXH = MIN(XMAXX,PARMDL(44))
22066 CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
22067 IVAL2 = 1
22068 MSPAR1 = 0
22069 MSPAR2 = 2
22070 MHPAR1 = 1
22071 MHPAR2 = 1
22072 ELSE IF(IFL1.EQ.0) THEN
22073 XMAXX = 1.D0 - XSS1 - AS
22074 XMAXH = MIN(XMAXX,PARMDL(44))
22075 CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
22076 IVAL1 = 1
22077 MSPAR1 = 2
22078 MSPAR2 = 0
22079 MHPAR1 = 1
22080 MHPAR2 = 1
22081
22082C incoming quark
22083 ELSE IF(ABS(IFL2).LE.12) THEN
22084 IF(IVAL2.EQ.1) THEN
22085 XS2(1) = 1.D0 - XSS2
22086 MSPAR1 = 0
22087 MSPAR2 = 1
22088 MHPAR1 = 1
22089 MHPAR2 = 1
22090 ELSE
22091 XMAXX = 1.D0 - XSS2 - AS
22092 XMAXH = MIN(XMAXX,PARMDL(44))
22093 CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
22094 MSPAR1 = 0
22095 MSPAR2 = 3
22096 MHPAR1 = 1
22097 MHPAR2 = 1
22098 ENDIF
22099 ELSE IF(ABS(IFL1).LE.12) THEN
22100 IF(IVAL1.EQ.1) THEN
22101 XS1(1) = 1.D0 - XSS1
22102 MSPAR1 = 1
22103 MSPAR2 = 0
22104 MHPAR1 = 1
22105 MHPAR2 = 1
22106 ELSE
22107 XMAXX = 1.D0 - XSS1 - AS
22108 XMAXH = MIN(XMAXX,PARMDL(44))
22109 CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
22110 MSPAR1 = 3
22111 MSPAR2 = 0
22112 MHPAR1 = 1
22113 MHPAR2 = 1
22114 ENDIF
22115
22116C double direct process
22117 ELSE IF(MSPR.EQ.14) THEN
22118 MSPAR1 = 0
22119 MSPAR2 = 0
22120 MHPAR1 = 1
22121 MHPAR2 = 1
22122
22123C unknown process
22124 ELSE
22125 WRITE(LO,'(/1X,A,I3/)')
22126 & 'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
22127 CALL PHO_ABORT
22128 ENDIF
22129
22130 IF(IREJ.NE.0) THEN
22131 IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
22132 & 'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
22133 GOTO 120
22134 ENDIF
22135
22136C soft particle momenta
22137 IF(MSPAR1.GT.0) THEN
22138 DO 50 I=1,MSPAR1
22139 PSOFT1(1,I) = 0.D0
22140 PSOFT1(2,I) = 0.D0
22141 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22142 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22143 50 CONTINUE
22144 ENDIF
22145 IF(MSPAR2.GT.0) THEN
22146 DO 55 I=1,MSPAR2
22147 PSOFT2(1,I) = 0.D0
22148 PSOFT2(2,I) = 0.D0
22149 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22150 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22151 55 CONTINUE
22152 ENDIF
22153C process counting
22154 MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
22155 KSOFT = MAX(MSPAR1,MSPAR2)
22156 KHARD = MAX(MHPAR1,MHPAR2)
22157C debug output
22158 IF(IDEB(25).GE.10) THEN
22159 WRITE(LO,'(/1X,A,2I3,3I5)')
22160 & 'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
22161 & IVAL1,IVAL2,MSPR,ITRY,NTRY
22162 IF(MSPAR1.GT.0) THEN
22163 WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
22164 DO 105 I=1,MSPAR1
22165 WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
22166 105 CONTINUE
22167 ENDIF
22168 IF(MSPAR2.GT.0) THEN
22169 WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
22170 DO 106 I=1,MSPAR2
22171 WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
22172 106 CONTINUE
22173 ENDIF
22174 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
22175 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
22176 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 1:',MHPAR1
22177 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
22178 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
22179 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
22180 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 2:',MHPAR2
22181 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
22182 ENDIF
22183 RETURN
22184
22185 450 CONTINUE
22186 IFAIL(16) = IFAIL(16)+1
22187 IF(IDEB(25).GE.2) THEN
22188 WRITE(LO,'(1X,A,3I5)')
22189 & 'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
22190 WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
22191 IF(IDEB(25).GE.5) THEN
22192 CALL PHO_PREVNT(0)
22193 ELSE
22194 CALL PHO_PREVNT(-1)
22195 ENDIF
22196 ENDIF
22197
22198 END
22199
22200*$ CREATE PHO_POMSCA.FOR
22201*COPY PHO_POMSCA
22202CDECK ID>, PHO_POMSCA
22203 SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
22204 & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
22205C**********************************************************************
22206C
22207C parton orientated formulation of soft and hard inelastic events
22208C
22209C
22210C input: II particle combiantion (1..4)
22211C MSPOM number of soft pomerons
22212C MHPOM number of semihard pomerons
22213C MSREG number of soft reggeons
22214C
22215C output: IVAL1,2 0 no valence quark engaged
22216C otherwise: position of valence quark engaged
22217C neg.number: gluon connected to valence quark
22218C by color flow
22219C MSPAR1,2 number of realized soft partons
22220C MHPAR1,2 number of realized hard partons
22221C IREJ 1 failure
22222C 0 success
22223C
22224C**********************************************************************
22225 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22226 SAVE
22227
22228 PARAMETER (TINY = 1.D-30 )
22229
22230C input/output channels
22231 INTEGER LI,LO
22232 COMMON /POINOU/ LI,LO
22233C event debugging information
22234 INTEGER NMAXD
22235 PARAMETER (NMAXD=100)
22236 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22237 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22238 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22239 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22240C model switches and parameters
22241 CHARACTER*8 MDLNA
22242 INTEGER ISWMDL,IPAMDL
22243 DOUBLE PRECISION PARMDL
22244 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22245C general process information
22246 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22247 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22248C nucleon-nucleus / nucleus-nucleus interface to DPMJET
22249 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22250 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22251 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22252 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22253C event weights and generated cross section
22254 INTEGER IPOWGC,ISWCUT,IVWGHT
22255 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22256 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22257 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22258C hard cross sections and MC selection weights
22259 INTEGER Max_pro_2
22260 PARAMETER ( Max_pro_2 = 16 )
22261 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22262 & MH_acc_1,MH_acc_2
22263 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22264 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22265 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22266 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22267 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22268 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22269C hard scattering parameters used for most recent hard interaction
22270 INTEGER NFbeta,NF
22271 DOUBLE PRECISION ALQCD2,BQCD
22272 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22273C data of c.m. system of Pomeron / Reggeon exchange
22274 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22275 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22276 & SIDP,CODP,SIFP,COFP
22277 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22278 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22279 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22280C obsolete cut-off information
22281 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22282 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22283C some hadron information, will be deleted in future versions
22284 INTEGER NFS
22285 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22286 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22287C data on most recent hard scattering
22288 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22289 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22290 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22291 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22292 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22293 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22294 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22295 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22296 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22297C light-cone x fractions and c.m. momenta of soft cut string ends
22298 INTEGER MAXSOF
22299 PARAMETER ( MAXSOF = 50 )
22300 INTEGER IJSI2,IJSI1
22301 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22302 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22303 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22304 & IJSI1(MAXSOF),IJSI2(MAXSOF)
22305C hard scattering data
22306 INTEGER MSCAHD
22307 PARAMETER ( MSCAHD = 50 )
22308 INTEGER LSCAHD,LSC1HD,LSIDX,
22309 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22310 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22311 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22312 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22313 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22314 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22315 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22316 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22317 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22318C table of particle indices for recursive PHOJET calls
22319 INTEGER MAXIPX
22320 PARAMETER ( MAXIPX = 100 )
22321 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22322 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22323 & IPOIX1,IPOIX2,IPOIX3
22324C internal rejection counters
22325 INTEGER NMXJ
22326 PARAMETER (NMXJ=60)
22327 CHARACTER*10 REJTIT
22328 INTEGER IFAIL
22329 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22330
22331 DIMENSION P1(4),P2(4),PD1(-6:6)
22332
22333 IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22334 & 'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22335
22336 ITRY = 0
22337 NTRY = 10
22338 IREJ = 0
22339 INMAX = 10
22340 MHARD = MHPOM
22341
22342C phase space limitation (single hard valence-valence quark scattering)
22343 IF(MHPOM.GT.0) THEN
22344 Emin = 2.D0*PTWANT + 0.2D0
22345 IF(ECMP.LT.Emin) THEN
22346 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22347 & 'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22348 IREJ = 50
22349 IFAIL(6) = IFAIL(6) + 1
22350 RETURN
22351 ENDIF
22352 ENDIF
22353
22354 SAS = PARMDL(160+II)/ECMP
22355 SAH = 2.D0*PTWANT/ECMP
22356 AS = SAS**2
22357 AH = SAH**2
22358
22359C save energy for leading particle effect
22360 XMAXP1 = 1.D0
22361 if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22362 XMAXP2 = 1.D0
22363 if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22364
22365C
22366C main loop to select hard and soft parton kinematics
22367C -----------------------------------------------------
22368 IFAIL(31) = IFAIL(31)+MHARD
22369 20 CONTINUE
22370 IREJ = 0
22371 IHARD = 0
22372 LSC1HD = 0
22373 ITRY = ITRY+1
22374 IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22375 IF(ITRY.GE.NTRY) THEN
22376 IREJ = 1
22377 GOTO 450
22378 ENDIF
22379 LINE = 0
22380 LSCAHD = 0
22381 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22382 XSS1 = MAX(0.D0,1.D0-XPSUB)
22383 XSS2 = MAX(0.D0,1.D0-XTSUB)
22384 ELSE
22385 XSS1 = 0.D0
22386 XSS2 = 0.D0
22387 ENDIF
22388 22 continue
22389
22390C partons needed to construct soft/hard interactions
22391 MSPAR1 = 2*MSPOM+MSREG+MHPOM
22392 MSPAR2 = MSPAR1
22393 MHPAR1 = MHPOM
22394 MHPAR2 = MHPOM
22395
22396C number of strings
22397 MSCHA = 2*MSPOM+MSREG
22398 MHCHA = 2*MHPOM
22399
22400 KSOFT = MSCHA
22401 KHARD = MHCHA
22402
22403C check actual phase space limit
22404 XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22405 IF(XX.GE.1.D0) THEN
22406 IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22407 & 'PHO_POMSCA: internal kin. rejection ',
22408 & '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22409 & MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22410 if(MSPOM+MSREG+MHPOM.gt.1) then
22411 if(MSREG.gt.0) then
22412 MSREG = MSREG-1
22413 else if(MSPOM.gt.0) THEN
22414 MSPOM = MSPOM-1
22415 else if(MHPOM.gt.1) then
22416 MHPOM = MHPOM-1
22417 endif
22418 goto 22
22419 endif
22420 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22421 & 'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22422 IREJ = 50
22423 IFAIL(6) = IFAIL(6) + 1
22424 RETURN
22425 ENDIF
22426
22427 XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22428 XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22429
22430C very low energy phase space restriction
22431 if(MHARD.gt.0) then
22432 if((XMAXX1*XMAXX2.le.AH)) then
22433 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22434 & 'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22435 IREJ = 50
22436 IFAIL(6) = IFAIL(6) + 1
22437 RETURN
22438 endif
22439 endif
22440
22441 AS = MAX(AS,PSOMIN/PCMP)
22442 ALNS = LOG(AS)
22443 ALNH = LOG(AH)
22444 Z1MAX = LOG(XMAXX1)
22445 Z2MAX = LOG(XMAXX2)
22446 Z1DIF = Z1MAX+Z2MAX-ALNH
22447 Z2DIF = Z1DIF
22448 PTMAX = 0.D0
22449C
22450C select hard parton momenta
22451C ------------------- begin of inner loop -------------------
22452 IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22453
22454 IF(MHARD.GT.MSCAHD) THEN
22455 WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22456 & 'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22457 IREJ = 1
22458 RETURN
22459 ENDIF
22460
22461 DO 11 NN=1,MHARD
22462C
22463C generate one resolved hard scattering
22464C
22465C high-pt option
22466 IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22467 CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22468 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22469 XSCUT = HSig(9)
22470 AHS = AH
22471 ALNHS = ALNH
22472 Z1DIFS = Z1DIF
22473 Z2DIFS = Z2DIF
22474 AH = (2.D0*PTWANT/ECMP)**2
22475 ALNH = LOG(AH)
22476 Z1DIF = Z1MAX+Z2MAX-ALNH
22477 Z2DIF = Z1DIF
22478 IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22479 IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22480 & 'PHO_POMSCA: kin.rejection, high-pt option ',
22481 & '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22482 IREJ = 5
22483 RETURN
22484 ENDIF
22485 CALL PHO_HARSCA(2,II)
22486 CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22487 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22488 AH = AHS
22489 ALNH = ALNHS
22490 Z1DIF = Z1DIFS
22491 Z2DIF = Z2DIFS
22492 IPOWGC(4+II) = IPOWGC(4+II)+1
22493 HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22494C minimum bias option
22495 ELSE
22496 CALL PHO_HARSCA(2,II)
22497 ENDIF
22498
22499C fill /POHSLT/
22500 LSIDX(NN) = NN
22501 LSCAHD = NN
22502 XHD(NN,1) = X1
22503 XHD(NN,2) = X2
22504 X0HD(NN,1) = X1
22505 X0HD(NN,2) = X2
22506 VHD(NN) = V
22507 ETAHD(NN,1) = ETAC
22508 ETAHD(NN,2) = ETAD
22509 PTHD(NN) = PT
22510 NPROHD(NN) = MSPR
22511 Q2SCA(NN,1) = QQPD
22512 Q2SCA(NN,2) = QQPD
22513 PDFVA(NN,1) = PDF1(IA)
22514 PDFVA(NN,2) = PDF2(IB)
22515 NINHD(NN,1) = IA
22516 NINHD(NN,2) = IB
22517 N0INHD(NN,1) = IA
22518 N0INHD(NN,2) = IB
22519 NIVAL(NN,1) = IV1
22520 NIVAL(NN,2) = IV2
22521 N0IVAL(NN,1) = IV1
22522 N0IVAL(NN,2) = IV2
22523 NOUTHD(NN,1) = IC
22524 NOUTHD(NN,2) = ID
22525 NBRAHD(NN,1) = IDPDG1
22526 NBRAHD(NN,2) = IDPDG2
22527 I3 = 8*(NN-1)
22528 I4 = 8*(NN-1)+4
22529 DO 50 I=1,4
22530 PPH(I3+I,1) = PHI1(I)
22531 PPH(I3+I,2) = PHI2(I)
22532 PPH(I4+I,1) = PHO1(I)
22533 PPH(I4+I,2) = PHO2(I)
22534 50 CONTINUE
22535
22536 11 CONTINUE
22537
22538C sort according to pt-hat
22539 DO 12 NN=1,MHARD
22540 PTMX = PTHD(LSIDX(NN))
22541 IPTM = NN
22542 DO 13 I=NN+1,MHARD
22543 IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22544 IPTM = I
22545 PTMX = PTHD(LSIDX(I))
22546 ENDIF
22547 13 CONTINUE
22548 IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22549 12 CONTINUE
22550 IPTM = LSIDX(1)
22551
22552C copy partons, generate ISR
22553 DO 15 L=1,MHARD
22554 NN = LSIDX(L)
22555 XSSS1 = XSS1+XHD(NN,1)
22556 XSSS2 = XSS2+XHD(NN,2)
22557C debug output
22558 IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22559 & 'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22560 & L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22561C check phase space
22562 IF( (XSSS1.GT.XMAXX1)
22563 & .OR.(XSSS2.GT.XMAXX2)
22564 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22565 IF(IHARD.EQ.0) THEN
22566 IF(ISWMDL(2).NE.1) GOTO 20
22567 MHPOM = 0
22568 MSPOM = 1
22569 MSREG = 0
22570 ENDIF
22571 GOTO 199
22572 ENDIF
22573
22574C reweight according to photon virtuality
22575 IF(IPAMDL(115).GE.1) THEN
22576 QQPD = Q2SCA(NN,1)
22577 WGX = 1.D0
22578 IF(IDPDG1.EQ.22) THEN
22579 IF(IPAMDL(115).EQ.1) THEN
22580 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22581 WG1 = 0.D0
22582 ELSE
22583 WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22584 & /LOG(QQPD/PARMDL(144))
22585 ENDIF
22586 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22587 ELSE IF(IPAMDL(115).EQ.2) THEN
22588 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22589 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22590 ENDIF
22591 WGX = WG1
22592 ENDIF
22593 QQPD = Q2SCA(NN,2)
22594 IF(IDPDG2.EQ.22) THEN
22595 IF(IPAMDL(115).EQ.1) THEN
22596 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22597 WG1 = 0.D0
22598 ELSE
22599 WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22600 & /LOG(QQPD/PARMDL(144))
22601 ENDIF
22602 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22603 ELSE IF(IPAMDL(115).EQ.2) THEN
22604 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22605 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22606 ENDIF
22607 WGX = WGX*WG1
22608 ENDIF
22609
22610 IF(IDEB(24).GE.25)
22611 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22612 & ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22613 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22614
22615 IF(WGX.LT.DT_RNDM(WGX)) THEN
22616 IF(L.EQ.1) THEN
22617 IREJ = 50
22618 RETURN
22619 ELSE
22620 GOTO 199
22621 ENDIF
22622 ENDIF
22623
22624 IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22625 & 'PHO_POMSCA: ',
22626 & 'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22627 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22628
22629 ENDIF
22630
22631C generate ISR
22632 IF((ISWMDL(8).GE.2)
22633 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22634 IF(IPAMDL(109).EQ.1) THEN
22635 Q2H = PARMDL(93)*PTHD(NN)**2
22636 ELSE
22637 Q2H = -PARMDL(93)*VHD(NN)
22638 & *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22639 ENDIF
22640 XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22641 XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22642 I3 = 8*NN-4
22643 DO 42 J=1,4
22644 P1(J) = PPH(I3+J,1)
22645 P2(J) = PPH(I3+J,2)
22646 42 CONTINUE
22647 IF(IDEB(24).GE.10)
22648 & WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22649 & 'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22650 & L,NN,XHD(NN,1),XHD(NN,2),Q2H
22651 J = NN
22652 IF(L.EQ.1) J = -NN
22653 CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22654 & N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22655 & X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22656 & NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22657 XSSS1 = XSSS1+XISR1-XHD(NN,1)
22658 XSSS2 = XSSS2+XISR2-XHD(NN,2)
22659 NINHD(NN,1) = IFL1
22660 NINHD(NN,2) = IFL2
22661 XHD(NN,1) = XISR1
22662 XHD(NN,2) = XISR2
22663 ENDIF
22664
22665C check phase space
22666 IF( (XSSS1.GT.XMAXX1)
22667 & .OR.(XSSS2.GT.XMAXX2)
22668 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22669 IF(IHARD.EQ.0) THEN
22670 IF(ISWMDL(2).NE.1) GOTO 20
22671 MHPOM = 0
22672 MSPOM = 1
22673 MSREG = 0
22674 ENDIF
22675 GOTO 199
22676 ENDIF
22677
22678C leave energy for leading particle effect
22679 IF((IHARD.GT.0).AND.
22680 & ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22681 GOTO 199
22682 endif
22683
22684C hard scattering accepted
22685 IHARD = IHARD+1
22686 XSS1 = XSSS1
22687 XSS2 = XSSS2
22688 IFAIL(31) = IFAIL(31)-1
22689
22690 15 CONTINUE
22691
22692C ------------------- end of inner (hard) loop -------------------
22693 199 CONTINUE
22694
22695 MHPOM = IHARD
22696 MHPAR1 = IHARD
22697 MHPAR2 = IHARD
22698
22699C count valences involved in hard scattering
22700 IVAL1 = 0
22701 IVAL2 = 0
22702 DO 17 L=1,IHARD
22703 NN = LSIDX(L)
22704 IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22705 IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22706 17 CONTINUE
22707
22708 IQUA1 = 0
22709 IQUA2 = 0
22710 IVGLU1 = 0
22711 IVGLU2 = 0
22712 DO 18 L=1,IHARD
22713 NN = LSIDX(L)
22714
22715C photon, pomeron valences
22716 IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22717 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22718 NIVAL(NN,1) = 1
22719 IVAL1 = NN
22720 ENDIF
22721 ENDIF
22722 IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22723 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22724 NIVAL(NN,2) = 1
22725 IVAL2 = NN
22726 ENDIF
22727 ENDIF
22728
22729C total number of quarks
22730 IF(NINHD(NN,1).NE.0) THEN
22731 IQUA1 = IQUA1+1
22732 ELSE IF(IVGLU1.EQ.0) THEN
22733 IVGLU1 = NN
22734 ENDIF
22735 IF(NINHD(NN,2).NE.0) THEN
22736 IQUA2 = IQUA2+1
22737 ELSE IF(IVGLU2.EQ.0) THEN
22738 IVGLU2 = NN
22739 ENDIF
22740 18 CONTINUE
22741
22742C gluons emitted by valence quarks
22743 VALPRO = 1.D0
22744 IF(II.EQ.1) VALPRO = VALPRG(1)
22745 IVQ1 = 1
22746 IVG1 = 0
22747 IVAL1 = MAX(IVAL1,0)
22748 IF(IVAL1.EQ.0) THEN
22749 IVQ1 = 0
22750 IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22751 IVAL1 = -IVGLU1
22752 IVG1 = 1
22753 ENDIF
22754 ENDIF
22755 VALPRO = 1.D0
22756 IF(II.EQ.1) VALPRO = VALPRG(2)
22757 IVQ2 = 1
22758 IVG2 = 0
22759 IVAL2 = MAX(IVAL2,0)
22760 IF(IVAL2.EQ.0) THEN
22761 IVQ2 = 0
22762 IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22763 IVAL2 = -IVGLU2
22764 IVG2 = 1
22765 ENDIF
22766 ENDIF
22767 MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22768C debug output
22769 IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22770 & 'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22771 & IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22772
22773C select soft X values
22774 25 CONTINUE
22775C number of soft/remnant quarks
22776 IF(MSPOM.EQ.0) THEN
22777 IF(IPAMDL(18).EQ.0) THEN
22778 MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22779 MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22780 ELSE
22781 MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22782 MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22783 ENDIF
22784 ELSE
22785 IF(IPAMDL(18).EQ.0) THEN
22786 MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22787 MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22788 ELSE
22789 MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22790 MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22791 ENDIF
22792 ENDIF
22793C debug output
22794 IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22795 & 'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22796 & MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22797
22798 XMAX1 = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22799 XMAX2 = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22800 I1 = IVQ1
22801 I2 = IVQ2
22802 IF(IVAL1.LE.0) I1 = 0
22803 IF(IVAL2.LE.0) I2 = 0
22804 IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22805 MSDIFF = 2*MSPOM
22806 ELSE
22807 MSDIFF = 2*MAX(0,MSPOM-1)
22808 ENDIF
22809 MSG1 = MSPAR1
22810 MSG2 = MSPAR2
22811 MSM1 = MSPAR1-MSDIFF
22812 MSM2 = MSPAR2-MSDIFF
22813 XMAXH1 = MIN(XMAX1,PARMDL(44))
22814 XMAXH2 = MIN(XMAX2,PARMDL(44))
22815 CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22816 & XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22817
22818C correct for proper simulation of high pt tail
22819 IF(IREJ.NE.0) THEN
22820 IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22821 & 'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22822 & MSPOM,MHPOM,I1,I2
22823 IF(MSPOM*MHPOM.GT.0) THEN
22824 MSPOM = MSPOM-1
22825 GOTO 25
22826 ELSE IF(MSPOM.GT.1) THEN
22827 MSPOM = MSPOM-1
22828 GOTO 25
22829 ELSE IF(MHPOM.GT.1) THEN
22830 IHARD = IHARD-1
22831 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22832 & .AND.(IPROCE.EQ.1)) THEN
22833 XSS1 = MAX(0.D0,1.D0-XPSUB)
22834 XSS2 = MAX(0.D0,1.D0-XTSUB)
22835 ELSE
22836 XSS1 = 0.D0
22837 XSS2 = 0.D0
22838 ENDIF
22839 DO 103 K=1,IHARD
22840 I = LSIDX(K)
22841 XSS1 = XSS1+ XHD(I,1)
22842 XSS2 = XSS2+ XHD(I,2)
22843 103 CONTINUE
22844 GOTO 199
22845 ENDIF
22846 IREJ = 4
22847 GOTO 450
22848 ENDIF
22849C accepted
22850 MSPOM = MSPOM-(MSPAR1-MSG1)/2
22851 MSPAR1 = MSG1
22852 MSPAR2 = MSG2
22853C ------------ kinematics sampled ---------------
22854C debug output
22855 IF(IDEB(24).GE.10) THEN
22856 WRITE(LO,'(1X,A,I3)')
22857 & 'PHO_POMSCA: soft x values, ITRY',ITRY
22858 DO 104 I=2,MAX(MSPAR1,MSPAR2)
22859 WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22860 104 CONTINUE
22861 ENDIF
22862 IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22863
22864C end of loop
22865 XS1(1) = 1.D0 - XSS1
22866 XS2(1) = 1.D0 - XSS2
22867
22868C process counting
22869 DO 30 N=1,LSCAHD
22870 MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22871 30 CONTINUE
22872
22873C soft particle momenta
22874
22875 IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22876 WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22877 & '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22878 IREJ = 1
22879 RETURN
22880 ENDIF
22881
22882 DO 55 I=1,MSPAR1
22883 PSOFT1(1,I) = 0.D0
22884 PSOFT1(2,I) = 0.D0
22885 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22886 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22887 55 CONTINUE
22888 DO 60 I=1,MSPAR2
22889 PSOFT2(1,I) = 0.D0
22890 PSOFT2(2,I) = 0.D0
22891 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22892 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22893 60 CONTINUE
22894
22895 KSOFT = MAX(MSPAR1,MSPAR2)
22896 KHARD = MAX(MHPAR1,MHPAR2)
22897 KSPOM = MSPOM
22898 KSREG = MSREG
22899 KHPOM = MHPOM
22900
22901C debug output
22902 IF(IDEB(24).GE.10) THEN
22903 WRITE(LO,'(/1X,A,2I3,2I5)')
22904 & 'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22905 & IVAL1,IVAL2,ITRY,NTRY
22906 IF(MSPAR1+MSPAR2.GT.0) THEN
22907 WRITE(LO,'(5X,A)') 'soft x particle1 particle2:'
22908 XTMP1 = 0.D0
22909 XTMP2 = 0.D0
22910 DO 105 I=1,MAX(MSPAR1,MSPAR2)
22911 IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22912 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22913 XTMP1 = XTMP1+XS1(I)
22914 XTMP2 = XTMP2+XS2(I)
22915 ELSE IF(I.LE.MSPAR1) THEN
22916 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22917 XTMP1 = XTMP1+XS1(I)
22918 ELSE IF(I.LE.MSPAR2) THEN
22919 WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22920 XTMP2 = XTMP2+XS2(I)
22921 ENDIF
22922 105 CONTINUE
22923 WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22924 ENDIF
22925 IF(MHPAR1.GT.0) THEN
22926 WRITE(LO,'(5X,A)')
22927 & 'NR IDX MSPR hard X / hard X ISR / flavor particle 1,2:'
22928 DO 107 K=1,MHPAR1
22929 I = LSIDX(K)
22930 WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22931 & K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22932 & NINHD(I,1),NINHD(I,2)
22933 XTMP1 = XTMP1+XHD(I,1)
22934 XTMP2 = XTMP2+XHD(I,2)
22935 107 CONTINUE
22936 WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22937 WRITE(LO,'(5X,A)') 'hard momenta particle1:'
22938 DO 108 K=1,MHPAR1
22939 I = LSIDX(K)
22940 I3 = 8*I-4
22941 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22942 & NOUTHD(I,1)
22943 108 CONTINUE
22944 WRITE(LO,'(5X,A)') 'hard momenta particle2:'
22945 DO 110 K=1,MHPAR2
22946 I = LSIDX(K)
22947 I3 = 8*I-4
22948 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22949 & NOUTHD(I,2)
22950 110 CONTINUE
22951 ENDIF
22952 ENDIF
22953 RETURN
22954
22955C event rejected, print debug information
22956 450 CONTINUE
22957 IFAIL(4) = IFAIL(4)+1
22958 IF(IDEB(24).GE.2) THEN
22959 WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22960 & 'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22961 & MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22962 WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22963 IF(IDEB(24).GE.5) THEN
22964 CALL PHO_PREVNT(0)
22965 ELSE
22966 CALL PHO_PREVNT(-1)
22967 ENDIF
22968 ENDIF
22969
22970 END
22971
22972*$ CREATE PHO_HARX12.FOR
22973*COPY PHO_HARX12
22974CDECK ID>, PHO_HARX12
22975 SUBROUTINE PHO_HARX12
22976C**********************************************************************
22977C
22978C selection of x1 and x2 according to 1/x1*1/x2
22979C
22980C**********************************************************************
22981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22982 SAVE
22983
22984 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22985
22986C input/output channels
22987 INTEGER LI,LO
22988 COMMON /POINOU/ LI,LO
22989C data on most recent hard scattering
22990 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22991 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22992 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22993 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22994 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22995 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22996 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22997 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22998 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22999
2300010 CONTINUE
23001 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
23002 Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
23003 IF ( (Z1+Z2).LT.ALNH ) GOTO 10
23004 X1 = EXP(Z1)
23005 X2 = EXP(Z2)
23006 AXX = AH/(X1*X2)
23007 W = SQRT(MAX(TINY,1.D0-AXX))
23008 W1 = AXX/(1.D0+W)
23009
23010 END
23011
23012*$ CREATE PHO_HARDX1.FOR
23013*COPY PHO_HARDX1
23014CDECK ID>, PHO_HARDX1
23015 SUBROUTINE PHO_HARDX1
23016C**********************************************************************
23017C
23018C selection of x1 according to 1/x1
23019C ( x2 = 1 )
23020C
23021C**********************************************************************
23022 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23023 SAVE
23024
23025 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23026
23027C input/output channels
23028 INTEGER LI,LO
23029 COMMON /POINOU/ LI,LO
23030C data on most recent hard scattering
23031 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23032 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23033 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23034 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23035 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23036 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23037 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23038 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23039 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23040
23041 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
23042 X2 = 1.D0
23043 X1 = EXP(Z1)
23044 AXX = AH/X1
23045 W = SQRT(MAX(TINY,1.D0-AXX))
23046 W1 = AXX/(1.D0+W)
23047
23048 END
23049
23050*$ CREATE PHO_HARKIN.FOR
23051*COPY PHO_HARKIN
23052CDECK ID>, PHO_HARKIN
23053 SUBROUTINE PHO_HARKIN(IREJ)
23054C***********************************************************************
23055C
23056C selection of kinematic variables
23057C (resolved and direct processes)
23058C
23059C***********************************************************************
23060 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23061 SAVE
23062
23063 PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
23064
23065C input/output channels
23066 INTEGER LI,LO
23067 COMMON /POINOU/ LI,LO
23068C event debugging information
23069 INTEGER NMAXD
23070 PARAMETER (NMAXD=100)
23071 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23072 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23073 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23074 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23075C data of c.m. system of Pomeron / Reggeon exchange
23076 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23077 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23078 & SIDP,CODP,SIFP,COFP
23079 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23080 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23081 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23082C data on most recent hard scattering
23083 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23084 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23085 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23086 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23087 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23088 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23089 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23090 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23091 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23092C internal cross check information on hard scattering limits
23093 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
23094 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
23095
23096 PARAMETER ( Max_pro_2 = 16 )
23097 DIMENSION RM(-1:Max_pro_2)
23098 DATA RM / 3.31D0, 0.0D0,
23099 & 7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
23100 & 0.45D0, 0.89D0, 0.89D0, 0.0D0, 4.776D0,
23101 & 0.615D0,4.776D0,0.615D0,1.0D0, 0.0D0,
23102 & 1.0D0 /
23103
23104 IREJ = 0
23105 M = MSPR
23106
23107C------------- resolved processes -----------
23108 IF ( M.EQ.1 ) THEN
2310910 CALL PHO_HARX12
23110 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23111 U =-1.D0-V
23112 R = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
23113 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23114 & 'PHO_HARKIN:weight error',M
23115 IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
23116 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23117 ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
2311820 CALL PHO_HARX12
23119 WL = LOG(W1)
23120 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23121 U =-1.D0-V
23122 R = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
23123 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23124 & 'PHO_HARKIN:weight error',M
23125 IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
23126 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23127 ELSEIF ( M.EQ.3 ) THEN
2312830 CALL PHO_HARX12
23129 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23130 U =-1.D0-V
23131 R = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
23132 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23133 & 'PHO_HARKIN:weight error',M
23134 IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
23135 ELSEIF ( M.EQ.5 ) THEN
2313650 CALL PHO_HARX12
23137 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
23138 U =-1.D0-V
23139 R = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
23140 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23141 & 'PHO_HARKIN:weight error',M
23142 IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
23143 ELSEIF ( M.EQ.6 ) THEN
2314460 CALL PHO_HARX12
23145 V =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
23146 U =-1.D0-V
23147 R = (4.D0/9.D0)*(U*U+V*V)*AXX
23148 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23149 & 'PHO_HARKIN:weight error',M
23150 IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
23151 ELSEIF ( M.EQ.7 ) THEN
2315270 CALL PHO_HARX12
23153 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23154 U =-1.D0-V
23155 R = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
23156 & -(4.D0/27.D0)*V/U)
23157 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23158 & 'PHO_HARKIN:weight error',M
23159 IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
23160 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23161 ELSEIF ( M.EQ.8 ) THEN
2316280 CALL PHO_HARX12
23163 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
23164 U =-1.D0-V
23165 R = (4.D0/9.D0)*(1.D0+U*U)
23166 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23167 & 'PHO_HARKIN:weight error',M
23168 IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
23169 ELSEIF ( M.EQ.-1 ) THEN
2317090 CALL PHO_HARX12
23171 WL = LOG(W1)
23172 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23173 U =-1.D0-V
23174 R = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
23175 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23176 & 'PHO_HARKIN:weight error',M
23177 IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
23178C------------- direct / single-resolved processes -----------
23179 ELSEIF ( M.EQ.10 ) THEN
23180100 CALL PHO_HARDX1
23181 WL = LOG(AXX/(1.D0+W)**2)
23182 U =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
23183 R = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
23184 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23185 & 'PHO_HARKIN:weight error',M
23186 IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
23187 V =-1.D0-U
23188 X2 = X1
23189 X1 = 1.D0
23190 ELSEIF ( M.EQ.11) THEN
23191110 CALL PHO_HARDX1
23192 WL = LOG(W1)
23193 U =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23194 V =-1.D0-U
23195 R = (U*U+V*V)/V*WL*AXX
23196 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23197 & 'PHO_HARKIN:weight error',M
23198 IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
23199 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23200 X2 = X1
23201 X1 = 1.D0
23202 ELSEIF ( M.EQ.12 ) THEN
23203120 CALL PHO_HARDX1
23204 WL = LOG(AXX/(1.D0+W)**2)
23205 V =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
23206 R = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
23207 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23208 & 'PHO_HARKIN:weight error',M
23209 IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
23210 ELSEIF ( M.EQ.13) THEN
23211130 CALL PHO_HARDX1
23212 WL = LOG(W1)
23213 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23214 U =-1.D0-V
23215 R = (U*U+V*V)/U*WL*AXX
23216 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23217 & 'PHO_HARKIN:weight error',M
23218 IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
23219 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23220C------------- (double) direct process -----------
23221 ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
23222 X1 = 1.D0
23223 X2 = 1.D0
23224 AXX= AH
23225 W = SQRT(MAX(TINY,1.D0-AXX))
23226 W1 = AXX/(1.D0+W)
23227 WL = LOG(W1)
23228 140 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23229 U =-1.D0-V
23230 R = -(U*U+V*V)/U
23231 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23232 & 'PHO_HARKIN:weight error',M
23233 IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
23234 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23235C---------------------------------------------
23236 ELSE
23237 WRITE(LO,'(/1X,A,I3)')
23238 & 'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
23239 CALL PHO_ABORT
23240 ENDIF
23241
23242 V = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23243 U = -1.D0-V
23244 U = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23245 PT = SQRT(U*V*X1*X2)*ECMP
23246 ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23247 ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23248
23249***************************************************************
23250 MM = M
23251 IF(M.EQ.-1) MM = 3
23252 ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23253 ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23254 ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23255 ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23256 XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23257 XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23258 XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23259 XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23260***************************************************************
23261
23262 IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23263 & 'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23264
23265 END
23266
23267*$ CREATE PHO_HARWGH.FOR
23268*COPY PHO_HARWGH
23269CDECK ID>, PHO_HARWGH
23270 SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23271C***********************************************************************
23272C
23273C calculate product of PDFs and coupling constants
23274C according to selected MSPR (process type)
23275C
23276C input: /POCKIN/
23277C
23278C output: PDS resulting from PDFs alone
23279C FDISTR complete weight function
23280C PDA,PDB fields containing the PDFs
23281C
23282C***********************************************************************
23283 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23284 SAVE
23285
23286 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23287
23288C input/output channels
23289 INTEGER LI,LO
23290 COMMON /POINOU/ LI,LO
23291C event debugging information
23292 INTEGER NMAXD
23293 PARAMETER (NMAXD=100)
23294 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23295 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23296 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23297 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23298C model switches and parameters
23299 CHARACTER*8 MDLNA
23300 INTEGER ISWMDL,IPAMDL
23301 DOUBLE PRECISION PARMDL
23302 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23303C data of c.m. system of Pomeron / Reggeon exchange
23304 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23305 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23306 & SIDP,CODP,SIFP,COFP
23307 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23308 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23309 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23310C currently activated parton density parametrizations
23311 CHARACTER*8 PDFNAM
23312 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23313 DOUBLE PRECISION PDFLAM,PDFQ2M
23314 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23315 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23316C hard scattering parameters used for most recent hard interaction
23317 INTEGER NFbeta,NF
23318 DOUBLE PRECISION ALQCD2,BQCD
23319 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23320C some hadron information, will be deleted in future versions
23321 INTEGER NFS
23322 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23323 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23324C scale parameters for parton model calculations
23325 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23326 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23327 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23328 & NQQAL,NQQALI,NQQALF,NQQPD
23329C data on most recent hard scattering
23330 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23331 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23332 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23333 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23334 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23335 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23336 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23337 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23338 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23339C hard cross sections and MC selection weights
23340 INTEGER Max_pro_2
23341 PARAMETER ( Max_pro_2 = 16 )
23342 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23343 & MH_acc_1,MH_acc_2
23344 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23345 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23346 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23347 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23348 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23349 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23350C some constants
23351 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23352 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23353 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23354
23355 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23356 DIMENSION PDA(-6:6),PDB(-6:6)
23357
23358 FDISTR = 0.D0
23359C set hard scale QQ for alpha and partondistr.
23360 IF ( NQQAL.EQ.1 ) THEN
23361 QQAL = AQQAL*PT*PT
23362 ELSEIF ( NQQAL.EQ.2 ) THEN
23363 QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23364 ELSEIF ( NQQAL.EQ.3 ) THEN
23365 QQAL = AQQAL*X1*X2*ECMP*ECMP
23366 ELSEIF ( NQQAL.EQ.4 ) THEN
23367 QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23368 ENDIF
23369 IF ( NQQPD.EQ.1 ) THEN
23370 QQPD = AQQPD*PT*PT
23371 ELSEIF ( NQQPD.EQ.2 ) THEN
23372 QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23373 ELSEIF ( NQQPD.EQ.3 ) THEN
23374 QQPD = AQQPD*X1*X2*ECMP*ECMP
23375 ELSEIF ( NQQPD.EQ.4 ) THEN
23376 QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23377 ENDIF
23378C coupling constants, PDFs
23379 IF(MSPR.LT.9) THEN
23380 ALPHA1 = PHO_ALPHAS(QQAL,3)
23381 ALPHA2 = ALPHA1
23382 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23383 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23384 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23385 PDS = PDA(0)*PDB(0)
23386 ELSE
23387 S2 = 0.D0
23388 S3 = 0.D0
23389 S4 = 0.D0
23390 S5 = 0.D0
23391 DO 10 I=1,NF
23392 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23393 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23394 S4 = S4+PDA(I)+PDA(-I)
23395 S5 = S5+PDB(I)+PDB(-I)
23396 10 CONTINUE
23397 IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23398 PDS = S2
23399 ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23400 PDS = PDA(0)*S5+PDB(0)*S4
23401 ELSE IF(MSPR.EQ.7) THEN
23402 PDS = S3
23403 ELSE IF(MSPR.EQ.8) THEN
23404 PDS = S4*S5-(S2+S3)
23405 ENDIF
23406 ENDIF
23407 ELSE IF(MSPR.LT.12) THEN
23408 ALPHA2 = PHO_ALPHAS(QQAL,2)
23409 IF(IDPDG1.EQ.22) THEN
23410 ALPHA1 = pho_alphae(QQAL)
23411 ELSE IF(IDPDG1.EQ.990) THEN
23412 ALPHA1 = PARMDL(74)
23413 ENDIF
23414 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23415 S4 = 0.D0
23416 S6 = 0.D0
23417 DO 15 I=1,NF
23418 S4 = S4+PDB(I)+PDB(-I)
23419C charge counting
23420* IF(MOD(I,2).EQ.0) THEN
23421* S6 = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23422* ELSE
23423* S6 = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23424* ENDIF
23425 S6 = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23426 15 CONTINUE
23427 IF(MSPR.EQ.10) THEN
23428 IF(IDPDG1.EQ.990) THEN
23429 PDS = S4
23430 ELSE
23431 PDS = S6
23432 ENDIF
23433 ELSE
23434 PDS = PDB(0)
23435 ENDIF
23436 ELSE IF(MSPR.LT.14) THEN
23437 ALPHA1 = PHO_ALPHAS(QQAL,1)
23438 IF(IDPDG2.EQ.22) THEN
23439 ALPHA2 = pho_alphae(QQAL)
23440 ELSE IF(IDPDG2.EQ.990) THEN
23441 ALPHA2 = PARMDL(74)
23442 ENDIF
23443 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23444 S4 = 0.D0
23445 S6 = 0.D0
23446 DO 20 I=1,NF
23447 S4 = S4+PDA(I)+PDA(-I)
23448C charge counting
23449* IF(MOD(I,2).EQ.0) THEN
23450* S6 = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23451* ELSE
23452* S6 = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23453* ENDIF
23454 S6 = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23455 20 CONTINUE
23456 IF(MSPR.EQ.12) THEN
23457 IF(IDPDG2.EQ.990) THEN
23458 PDS = S4
23459 ELSE
23460 PDS = S6
23461 ENDIF
23462 ELSE
23463 PDS = PDA(0)
23464 ENDIF
23465 ELSE IF(MSPR.EQ.14) THEN
23466 SSR = X1*X2*ECMP*ECMP
23467 IF(IDPDG1.EQ.22) THEN
23468 ALPHA1 = pho_alphae(SSR)
23469 ELSE IF(IDPDG1.EQ.990) THEN
23470 ALPHA1 = PARMDL(74)
23471 ENDIF
23472 IF(IDPDG2.EQ.22) THEN
23473 ALPHA2 = pho_alphae(SSR)
23474 ELSE IF(IDPDG2.EQ.990) THEN
23475 ALPHA2 = PARMDL(74)
23476 ENDIF
23477 PDS = 1.D0
23478 ELSE
23479 WRITE(LO,'(/1X,A,I4)')
23480 & 'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23481 CALL PHO_ABORT
23482 ENDIF
23483
23484C complete weight
23485 FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23486
23487C debug output
23488 IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23489 & 'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23490 & MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23491
23492 END
23493
23494*$ CREATE PHO_HARSCA.FOR
23495*COPY PHO_HARSCA
23496CDECK ID>, PHO_HARSCA
23497 SUBROUTINE PHO_HARSCA(IMODE,IP)
23498C***********************************************************************
23499C
23500C PHO_HARSCA determines the type of hard subprocess, the partons
23501C taking part in this subprocess and the kinematic variables
23502C
23503C input: IMODE 1 direct processes
23504C 2 resolved processes
23505C -1 initialization
23506C -2 output of statistics
23507C IP 1-4 particle combination (hadron/photon)
23508C
23509C***********************************************************************
23510 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23511 SAVE
23512
23513 PARAMETER( EPS = 1.D-10,
23514 & DEPS = 1.D-30 )
23515
23516C input/output channels
23517 INTEGER LI,LO
23518 COMMON /POINOU/ LI,LO
23519C event debugging information
23520 INTEGER NMAXD
23521 PARAMETER (NMAXD=100)
23522 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23523 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23524 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23525 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23526C model switches and parameters
23527 CHARACTER*8 MDLNA
23528 INTEGER ISWMDL,IPAMDL
23529 DOUBLE PRECISION PARMDL
23530 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23531C internal rejection counters
23532 INTEGER NMXJ
23533 PARAMETER (NMXJ=60)
23534 CHARACTER*10 REJTIT
23535 INTEGER IFAIL
23536 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23537C hard scattering parameters used for most recent hard interaction
23538 INTEGER NFbeta,NF
23539 DOUBLE PRECISION ALQCD2,BQCD
23540 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23541C data of c.m. system of Pomeron / Reggeon exchange
23542 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23543 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23544 & SIDP,CODP,SIFP,COFP
23545 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23546 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23547 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23548C names of hard scattering processes
23549 INTEGER Max_pro_1
23550 PARAMETER ( Max_pro_1 = 16 )
23551 CHARACTER*18 PROC
23552 COMMON /POHPRO/ PROC(0:Max_pro_1)
23553C data on most recent hard scattering
23554 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23555 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23556 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23557 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23558 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23559 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23560 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23561 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23562 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23563C hard scattering data
23564 INTEGER MSCAHD
23565 PARAMETER ( MSCAHD = 50 )
23566 INTEGER LSCAHD,LSC1HD,LSIDX,
23567 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23568 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23569 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23570 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23571 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23572 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23573 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23574 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23575 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23576C hard cross sections and MC selection weights
23577 INTEGER Max_pro_2
23578 PARAMETER ( Max_pro_2 = 16 )
23579 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23580 & MH_acc_1,MH_acc_2
23581 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23582 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23583 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23584 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23585 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23586 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23587C cross sections
23588 INTEGER IPFIL,IFAFIL,IFBFIL
23589 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23590 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23591 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23592 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23593 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23594 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23595 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23596 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23597 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23598 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23599 & IPFIL,IFAFIL,IFBFIL
23600C some constants
23601 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23602 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23603 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23604
23605 111 CONTINUE
23606
23607C resolved processes
23608 IF(IMODE.EQ.2) THEN
23609
23610 MH_pro_on(0,IP) = 0
23611 HWgx(9) = 0.D0
23612 DO 15 M=-1,8
23613 IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23614 15 CONTINUE
23615 IF(HWgx(9).LT.DEPS) THEN
23616 WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23617 & 'no resolved process possible for IP',IP,HWgx(9)
23618 CALL PHO_ABORT
23619 ENDIF
23620C
23621C ----------------------------------------------I
23622C begin of iteration loop (resolved processes) I
23623C I
23624 IREJSC = 0
23625 10 CONTINUE
23626 IREJSC = IREJSC+1
23627 IF(IREJSC.GT.1000) THEN
23628 WRITE(LO,'(/1X,A,I10)')
23629 & 'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23630 CALL PHO_ABORT
23631 ENDIF
23632
23633C find subprocess
23634 B = DT_RNDM(X1)*HWgx(9)
23635 MSPR =-2
23636 SUM = 0.D0
23637 20 MSPR = MSPR+1
23638 IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23639 IF ( SUM.LT.B .AND. MSPR.LT.8 ) GOTO 20
23640
23641 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23642 & 'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23643
23644C find kin. variables X1,X2 and V
23645 CALL PHO_HARKIN(IREJ)
23646 IF(IREJ.NE.0) THEN
23647 IFAIL(29) = IFAIL(29)+1
23648 GOTO 10
23649 ENDIF
23650C calculate remaining distribution
23651 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23652C actualize counter for cross-section calculation
23653 if(F.LE.1.D-15) then
23654 F = 0.D0
23655 goto 10
23656 endif
23657* XSECT(5,MSPR) = XSECT(5,MSPR)+F
23658* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23659 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23660C check F against FMAX
23661 WEIGHT = F/(HWgx(MSPR)+DEPS)
23662 IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23663C-------------------------------------------------------------------
23664 IF(WEIGHT.GT.1.D0) THEN
23665 WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23666 1234 FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23667 & 2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23668 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23669 & ECMP,PTWANT,AS,AH,PT
23670 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23671 & ETAC,ETAD,X1,X2,V
23672 CALL PHO_PREVNT(-1)
23673 ENDIF
23674C-------------------------------------------------------------------
23675C I
23676C end of iteration loop (resolved processes) I
23677C --------------------------------------------I
23678C
23679C*********************************************************************
23680C
23681C direct processes
23682
23683 ELSE IF(IMODE.EQ.1) THEN
23684
23685C single-resolved processes kinematically forbidden
23686 if(Z1DIF.lt.0.D0) then
23687 HWgx(10) = 0.D0
23688 HWgx(11) = 0.D0
23689 HWgx(12) = 0.D0
23690 HWgx(13) = 0.D0
23691 endif
23692
23693 HWgx(15) = 0.D0
23694 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23695 DO M= 10,14
23696 IF(MH_pro_on(M,IP).EQ.1) then
23697 if((M.eq.10).or.(M.eq.11)) then
23698 fac = FSUH(1)*FSUP(2)
23699 else if((M.eq.12).or.(M.eq.13)) then
23700 fac = FSUP(1)*FSUH(2)
23701 else
23702 fac = FSUH(1)*FSUH(2)
23703 endif
23704 HWgx(15) = HWgx(15)+HWgx(M)*fac
23705 endif
23706 ENDDO
23707 else
23708 DO M= 10,14
23709 IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23710 ENDDO
23711 endif
23712 IF(HWgx(15).LT.DEPS) THEN
23713 WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23714 & 'no direct/single-resolved process possible (IP)',IP
23715 CALL PHO_ABORT
23716 ENDIF
23717C
23718C ----------------------------------------------I
23719C begin of iteration loop (direct processes) I
23720C I
23721 IREJSC = 0
23722 100 CONTINUE
23723 IREJSC = IREJSC+1
23724 IF(IREJSC.GT.1000) THEN
23725 WRITE(LO,'(/1X,A,I10)')
23726 & 'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23727 CALL PHO_ABORT
23728 ENDIF
23729
23730C find subprocess
23731 B = DT_RNDM(X1)*HWgx(15)
23732 MSPR = 9
23733 SUM = 0.D0
23734 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23735 150 continue
23736 MSPR = MSPR+1
23737 IF(MH_pro_on(MSPR,IP).EQ.1) then
23738 if((MSPR.eq.10).or.(MSPR.eq.11)) then
23739 fac = FSUH(1)*FSUP(2)
23740 else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23741 fac = FSUP(1)*FSUH(2)
23742 else
23743 fac = FSUH(1)*FSUH(2)
23744 endif
23745 SUM = SUM+HWgx(MSPR)*fac
23746 endif
23747 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 150
23748 else
23749 200 continue
23750 MSPR = MSPR+1
23751 IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23752 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 200
23753 endif
23754
23755 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23756 & 'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23757
23758C find kin. variables X1,X2 and V
23759 CALL PHO_HARKIN(IREJ)
23760 IF(IREJ.NE.0) THEN
23761 IFAIL(28) = IFAIL(28)+1
23762 GOTO 100
23763 ENDIF
23764
23765C calculate remaining distribution
23766 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23767
23768C counter for cross-section calculation
23769 if(F.LE.1.D-15) then
23770 F=0.D0
23771 goto 100
23772 endif
23773* XSECT(5,MSPR) = XSECT(5,MSPR)+F
23774* XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23775 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23776C check F against FMAX
23777 WEIGHT = F/(HWgx(MSPR)+DEPS)
23778 IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23779C-------------------------------------------------------------------
23780 IF(WEIGHT.GT.1.D0) THEN
23781 WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23782 1235 FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23783 & 2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23784 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23785 & ECMP,PTWANT,AS,AH,PT
23786 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23787 & ETAC,ETAD,X1,X2,V
23788 CALL PHO_PREVNT(-1)
23789 ENDIF
23790C-------------------------------------------------------------------
23791C I
23792C end of iteration loop (direct processes) I
23793C --------------------------------------------I
23794
23795 ELSE IF(IMODE.EQ.-1) THEN
23796
23797C initialize cross section calculations
23798
23799 DO 40 M=-1,Max_pro_2
23800* DO 30 I=5,6
23801* XSECT(I,M) = 0.D0
23802*30 CONTINUE
23803C reset counters
23804 DO 35 J=1,4
23805 MH_tried(M,J) = 0
23806 MH_acc_1(M,J) = 0
23807 MH_acc_2(M,J) = 0
23808 35 CONTINUE
23809 40 CONTINUE
23810 IF(IDEB(78).GE.0) THEN
23811 WRITE(LO,'(/1X,A,/1X,A)')
23812 & 'PHO_HARSCA: activated hard processes',
23813 & '------------------------------------'
23814 WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
23815 DO 42 M=1,Max_pro_2
23816 WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23817 & (MH_pro_on(M,J),J=1,4)
23818 42 CONTINUE
23819 ENDIF
23820 RETURN
23821
23822 ELSE IF(IMODE.EQ.-2) THEN
23823
23824C calculation of process statistics
23825
23826 do K=1,4
23827
23828 MH_tried(0,K) = 0
23829 MH_acc_1(0,K) = 0
23830 MH_acc_2(0,K) = 0
23831 MH_tried(9,K) = 0
23832 MH_acc_1(9,K) = 0
23833 MH_acc_2(9,K) = 0
23834 MH_tried(15,K) = 0
23835 MH_acc_1(15,K) = 0
23836 MH_acc_2(15,K) = 0
23837
23838 MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23839 MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23840 MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23841
23842 do M=1,8
23843 MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23844 MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23845 MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23846 enddo
23847 do M=10,14
23848 MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23849 MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23850 MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23851 enddo
23852 MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23853 MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23854 MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23855 enddo
23856
23857 IF(IDEB(78).GE.1) THEN
23858 WRITE(LO,'(/1X,A,/1X,A)')
23859 & 'PHO_HARSCA: internal rejection statistics',
23860 & '-----------------------------------------'
23861 do K=1,4
23862 IF(MH_tried(0,K).GT.0) THEN
23863 WRITE(LO,'(5X,A,I3)')
23864 & 'process (sampled/accepted) for IP:',K
23865 do M=0,Max_pro_2
23866 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23867 & MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23868 & dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23869 enddo
23870 ENDIF
23871 enddo
23872 ENDIF
23873 RETURN
23874
23875 ELSE
23876 WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23877 & 'unsupported mode',IMODE
23878 CALL PHO_ABORT
23879 ENDIF
23880
23881C the event is accepted now
23882C actualize counter for accepted events
23883 MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23884 IF(MSPR.EQ.-1) MSPR = 3
23885C
23886C find flavor of initial partons
23887C
23888 SUM = 0.D0
23889 SCHECK = DT_RNDM(SUM)*PDS-EPS
23890 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23891 IA = 0
23892 IB = 0
23893 ELSEIF ( MSPR.EQ.2 .OR. MSPR.EQ.5 .OR. MSPR.EQ.6 ) THEN
23894 DO 610 IA=-NF,NF
23895 IF ( IA.EQ.0 ) GOTO 610
23896 SUM = SUM+PDF1(IA)*PDF2(-IA)
23897 IF ( SUM.GE.SCHECK ) GOTO 620
23898 610 CONTINUE
23899 620 IB =-IA
23900 ELSEIF ( MSPR.EQ.3 ) THEN
23901 IB = 0
23902 DO 630 IA=-NF,NF
23903 IF ( IA.EQ.0 ) GOTO 630
23904 SUM = SUM+PDF1(0)*PDF2(IA)
23905 IF ( SUM.GE.SCHECK ) GOTO 640
23906 SUM = SUM+PDF1(IA)*PDF2(0)
23907 IF ( SUM.GE.SCHECK ) GOTO 650
23908 630 CONTINUE
23909 640 IB = IA
23910 IA = 0
23911 650 CONTINUE
23912 ELSEIF ( MSPR.EQ.7 ) THEN
23913 DO 660 IA=-NF,NF
23914 IF ( IA.EQ.0 ) GOTO 660
23915 SUM = SUM+PDF1(IA)*PDF2(IA)
23916 IF ( SUM.GE.SCHECK ) GOTO 670
23917 660 CONTINUE
23918 670 IB = IA
23919 ELSEIF ( MSPR.EQ.8 ) THEN
23920 DO 690 IA=-NF,NF
23921 IF ( IA.EQ.0 ) GOTO 690
23922 DO 680 IB=-NF,NF
23923 IF ( ABS(IB).EQ.ABS(IA) .OR. IB.EQ.0 ) GOTO 680
23924 SUM = SUM+PDF1(IA)*PDF2(IB)
23925 IF ( SUM.GE.SCHECK ) GOTO 700
23926 680 CONTINUE
23927 690 CONTINUE
23928 700 CONTINUE
23929 ELSEIF ( MSPR.EQ.10 ) THEN
23930 IA = 0
23931 DO 710 IB=-NF,NF
23932 IF ( IB.NE.0 ) THEN
23933 IF(IDPDG1.EQ.22) THEN
23934* IF(MOD(ABS(IB),2).EQ.0) THEN
23935* SUM = SUM+PDF2(IB)*4.D0/9.D0
23936* ELSE
23937* SUM = SUM+PDF2(IB)*1.D0/9.D0
23938* ENDIF
23939 SUM = SUM+PDF2(IB)*Q_ch2(IB)
23940 ELSE
23941 SUM = SUM+PDF2(IB)
23942 ENDIF
23943 IF ( SUM.GE.SCHECK ) GOTO 720
23944 ENDIF
23945 710 CONTINUE
23946 720 CONTINUE
23947 ELSEIF ( MSPR.EQ.12 ) THEN
23948 IB = 0
23949 DO 810 IA=-NF,NF
23950 IF ( IA.NE.0 ) THEN
23951 IF(IDPDG2.EQ.22) THEN
23952* IF(MOD(ABS(IA),2).EQ.0) THEN
23953* SUM = SUM+PDF1(IA)*4.D0/9.D0
23954* ELSE
23955* SUM = SUM+PDF1(IA)*1.D0/9.D0
23956* ENDIF
23957 SUM = SUM+PDF1(IA)*Q_ch2(IA)
23958 ELSE
23959 SUM = SUM+PDF1(IA)
23960 ENDIF
23961 IF ( SUM.GE.SCHECK ) GOTO 820
23962 ENDIF
23963 810 CONTINUE
23964 820 CONTINUE
23965 ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23966 IA = 0
23967 IB = 0
23968 ENDIF
23969C final check
23970 IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
23971 write(LO,*) 'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23972 write(LO,*) 'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
23973 GOTO 111
23974 ENDIF
23975C
23976C find flavour of final partons
23977C
23978 IC = IA
23979 ID = IB
23980 IF ( MSPR.EQ.2 ) THEN
23981 IC = 0
23982 ID = 0
23983 ELSEIF ( MSPR.EQ.4 ) THEN
23984 IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23985 IF ( IC.GT.NF ) IC = NF-IC
23986 ID =-IC
23987 ELSEIF ( MSPR.EQ.6 ) THEN
23988 IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23989 IF ( IC.GT.NF-1 ) IC = NF-1-IC
23990 IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23991 ID =-IC
23992 ELSEIF ( MSPR.EQ.11) THEN
23993 SUM = 0.D0
23994 DO 730 IC=-NF,NF
23995 IF ( IC.NE.0 ) THEN
23996 IF(IDPDG1.EQ.22) THEN
23997* IF(MOD(ABS(IC),2).EQ.0) THEN
23998* SUM = SUM + 4.D0
23999* ELSE
24000* SUM = SUM + 1.D0
24001* ENDIF
24002 SUM = SUM + Q_ch2(IC)
24003 ELSE
24004 SUM = SUM + 1.D0
24005 ENDIF
24006 ENDIF
24007 730 CONTINUE
24008 SCHECK = DT_RNDM(SUM)*SUM-EPS
24009 SUM = 0.D0
24010 DO 740 IC=-NF,NF
24011 IF ( IC.NE.0 ) THEN
24012 IF(IDPDG1.EQ.22) THEN
24013* IF(MOD(ABS(IC),2).EQ.0) THEN
24014* SUM = SUM + 4.D0
24015* ELSE
24016* SUM = SUM + 1.D0
24017* ENDIF
24018 SUM = SUM + Q_ch2(IC)
24019 ELSE
24020 SUM = SUM + 1.D0
24021 ENDIF
24022 IF ( SUM.GE.SCHECK ) GOTO 750
24023 ENDIF
24024 740 CONTINUE
24025 750 CONTINUE
24026 ID = -IC
24027 ELSEIF ( MSPR.EQ.12) THEN
24028 IC = 0
24029 ID = IA
24030 ELSEIF ( MSPR.EQ.13) THEN
24031 SUM = 0.D0
24032 DO 830 IC=-NF,NF
24033 IF ( IC.NE.0 ) THEN
24034 IF(IDPDG2.EQ.22) THEN
24035* IF(MOD(ABS(IC),2).EQ.0) THEN
24036* SUM = SUM + 4.D0
24037* ELSE
24038* SUM = SUM + 1.D0
24039* ENDIF
24040 SUM = SUM + Q_ch2(IC)
24041 ELSE
24042 SUM = SUM + 1.D0
24043 ENDIF
24044 ENDIF
24045 830 CONTINUE
24046 SCHECK = DT_RNDM(SUM)*SUM-EPS
24047 SUM = 0.D0
24048 DO 840 IC=-NF,NF
24049 IF ( IC.NE.0 ) THEN
24050 IF(IDPDG2.EQ.22) THEN
24051* IF(MOD(ABS(IC),2).EQ.0) THEN
24052* SUM = SUM + 4.D0
24053* ELSE
24054* SUM = SUM + 1.D0
24055* ENDIF
24056 SUM = SUM + Q_ch2(IC)
24057 ELSE
24058 SUM = SUM + 1.D0
24059 ENDIF
24060 IF ( SUM.GE.SCHECK ) GOTO 850
24061 ENDIF
24062 840 CONTINUE
24063 850 CONTINUE
24064 ID = -IC
24065 ELSEIF ( MSPR.EQ.14) THEN
24066 SUM = 0.D0
24067 DO 930 IC=1,NF
24068 FAC1 = 1.D0
24069 FAC2 = 1.D0
24070 IF(MOD(ABS(IC),2).EQ.0) THEN
24071 IF(IDPDG1.EQ.22) FAC1 = 4.D0
24072 IF(IDPDG2.EQ.22) FAC2 = 4.D0
24073 ENDIF
24074 SUM = SUM + FAC1*FAC2
24075 930 CONTINUE
24076 IF(IPAMDL(64).NE.0) THEN
24077 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
24078 ENDIF
24079 SCHECK = DT_RNDM(SUM)*SUM-EPS
24080 SUM = 0.D0
24081 DO 940 IC=1,NF
24082 FAC1 = 1.D0
24083 FAC2 = 1.D0
24084 IF(MOD(ABS(IC),2).EQ.0) THEN
24085 IF(IDPDG1.EQ.22) FAC1 = 4.D0
24086 IF(IDPDG2.EQ.22) FAC2 = 4.D0
24087 ENDIF
24088 SUM = SUM + FAC1*FAC2
24089 IF ( SUM.GE.SCHECK ) GOTO 950
24090 940 CONTINUE
24091 IC = 15
24092 950 CONTINUE
24093 ID = -IC
24094 IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
24095 ENDIF
24096 if(IC.eq.0) then
24097 XM3 = 0.D0
24098 else
24099 XM3 = PHO_PMASS(IC,3)
24100 endif
24101 if(ID.eq.0) then
24102 XM4 = 0.D0
24103 else
24104 XM4 = PHO_PMASS(ID,3)
24105 endif
24106 IF(ABS(IC).EQ.15) GOTO 955
24107
24108C valence quarks involved?
24109 IV1 = 0
24110 IF(IA.NE.0) THEN
24111 IF(IDPDG1.EQ.22) THEN
24112 CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
24113 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
24114 ELSE
24115 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
24116 ENDIF
24117 ENDIF
24118 IV2 = 0
24119 IF(IB.NE.0) THEN
24120 IF(IDPDG2.EQ.22) THEN
24121 CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
24122 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
24123 ELSE
24124 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
24125 ENDIF
24126 ENDIF
24127C
24128C fill event record
24129C
24130 955 CONTINUE
24131 CALL PHO_SFECFE(SINPHI,COSPHI)
24132 ECM2 = ECMP/2.D0
24133C incoming partons
24134 PHI1(1) = 0.D0
24135 PHI1(2) = 0.D0
24136 PHI1(3) = ECM2*X1
24137 PHI1(4) = PHI1(3)
24138 PHI1(5) = 0.D0
24139 PHI2(1) = 0.D0
24140 PHI2(2) = 0.D0
24141 PHI2(3) = -ECM2*X2
24142 PHI2(4) = -PHI2(3)
24143 PHI2(5) = 0.D0
24144C outgoing partons
24145 PHO1(1) = PT*COSPHI
24146 PHO1(2) = PT*SINPHI
24147 PHO1(3) = -ECM2*(U*X1-V*X2)
24148 PHO1(4) = -ECM2*(U*X1+V*X2)
24149 PHO1(5) = XM3
24150 PHO2(1) = -PHO1(1)
24151 PHO2(2) = -PHO1(2)
24152 PHO2(3) = -ECM2*(V*X1-U*X2)
24153 PHO2(4) = -ECM2*(V*X1+U*X2)
24154 PHO2(5) = XM4
24155
24156C convert to mass shell
24157 CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
24158 IF(IREJ.NE.0) THEN
24159 IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
24160 & 'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
24161 & PT,XM3,XM4
24162 GOTO 111
24163 ENDIF
24164 PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
24165
24166C debug output
24167 IF(IDEB(78).GE.20) THEN
24168 SHAT = X1*X2*ECMP*ECMP
24169 WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
24170 & MSPR,IA,IB,IC,ID
24171 WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
24172 WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
24173 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
24174 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
24175 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
24176 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
24177 ENDIF
24178
24179 END
24180
24181*$ CREATE PHO_HARFAC.FOR
24182*COPY PHO_HARFAC
24183CDECK ID>, PHO_HARFAC
24184 SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
24185C*********************************************************************
24186C
24187C initialization: find scaling factors and maxima of remaining
24188C weights
24189C
24190C input: PTCUT transverse momentum cutoff
24191C ECMI cms energy
24192C
24193C output: Hfac(-1:Max_pro_2) field for sampling hard processes
24194C
24195C*********************************************************************
24196 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24197 SAVE
24198
24199 PARAMETER ( MXABWT = 96 )
24200
24201C input/output channels
24202 INTEGER LI,LO
24203 COMMON /POINOU/ LI,LO
24204C data of c.m. system of Pomeron / Reggeon exchange
24205 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24206 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24207 & SIDP,CODP,SIFP,COFP
24208 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24209 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24210 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24211C some constants
24212 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24213 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24214 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24215C hard scattering parameters used for most recent hard interaction
24216 INTEGER NFbeta,NF
24217 DOUBLE PRECISION ALQCD2,BQCD
24218 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24219C integration precision for hard cross sections (obsolete)
24220 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24221 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24222C data on most recent hard scattering
24223 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24224 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24225 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24226 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24227 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24228 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24229 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24230 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24231 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24232C hard cross sections and MC selection weights
24233 INTEGER Max_pro_2
24234 PARAMETER ( Max_pro_2 = 16 )
24235 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24236 & MH_acc_1,MH_acc_2
24237 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24238 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24239 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24240 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24241 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24242 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24243
24244 DIMENSION ABSZ(MXABWT),WEIG(MXABWT)
24245 DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24246 & F124(-1:Max_pro_2)
24247 DATA F124 / 1.D0,0.D0,
24248 & 4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24249 & 2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24250
24251 SS = ECMI*ECMI
24252 AH = (2.D0*PTCUT/ECMI)**2
24253 ALN = LOG(AH)
24254 HLN = LOG(0.5D0)
24255 NPOINT = NGAUIN
24256 CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24257 DO 10 M=-1,Max_pro_2
24258 S1(M) = 0.D0
2425910 CONTINUE
24260
24261C resolved processes
24262 DO 80 I1=1,NPOINT
24263 Z1 = ABSZ(I1)
24264 X1 = EXP(ALN*Z1)
24265 DO 20 M=-1,9
24266 S2(M) = 0.D0
2426720 CONTINUE
24268
24269 DO 60 I2=1,NPOINT
24270 Z2 = (1.D0-Z1)*ABSZ(I2)
24271 X2 = EXP(ALN*Z2)
24272 FAXX = AH/(X1*X2)
24273 W = SQRT(1.D0-FAXX)
24274 W1 = FAXX/(1.+W)
24275 WLOG = LOG(W1)
24276 FWW = FAXX*WLOG/W
24277 DO 30 M=-1,9
24278 S(M) = 0.D0
2427930 CONTINUE
24280
24281 DO 40 I=1,NPOINT
24282 Z = ABSZ(I)
24283 VA =-0.5D0*W1/(W1+Z*W)
24284 UA =-1.D0-VA
24285 VB =-0.5D0*FAXX/(W1+2.D0*W*Z)
24286 UB =-1.D0-VB
24287 VC =-EXP(HLN+Z*WLOG)
24288 UC =-1.D0-VC
24289 VE =-0.5D0*(1.D0+W)+Z*W
24290 UE =-1.D0-VE
24291 S(1) = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24292 & WEIG(I)
24293 S(2) = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24294 & WEIG(I)
24295 S(3) = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24296 S(5) = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24297 & (8./27.)*UA*UA*VA)*WEIG(I)
24298 S(6) = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24299 S(7) = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24300 & (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24301 S(8) = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24302 S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
2430340 CONTINUE
24304 S(4) = S(2)*(9./32.)
24305 DO 50 M=-1,8
24306 S2(M) = S2(M)+S(M)*WEIG(I2)*W
2430750 CONTINUE
2430860 CONTINUE
24309 DO 70 M=-1,8
24310 S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
2431170 CONTINUE
2431280 CONTINUE
24313 S1(4) = S1(4)*NF
24314 S1(6) = S1(6)*MAX(0,NF-1)
24315C
24316C direct processes
24317 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24318 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24319 DO 180 I1=1,NPOINT
24320 Z2 = ABSZ(I1)
24321 X2 = EXP(ALN*Z2)
24322 FAXX = AH/X2
24323 W = SQRT(1.D0-FAXX)
24324 W1 = FAXX/(1.D0+W)
24325 WLOG = LOG(W1)
24326 WL = LOG(FAXX/(1.D0+W)**2)
24327 FWW1 = FAXX*WL/ALN
24328 FWW2 = FAXX*WLOG/ALN
24329 DO 130 M=10,12
24330 S(M) = 0.D0
24331 130 CONTINUE
24332C
24333 DO 140 I=1,NPOINT
24334 Z = ABSZ(I)
24335 UA =-(1.D0+W)/2.D0*EXP(Z*WL)
24336 VA =-1.D0-UA
24337 VB =-EXP(HLN+Z*WLOG)
24338 UB =-1.D0-VB
24339 S(10) = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24340 S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24341 140 CONTINUE
24342 DO 170 M=10,11
24343 S1(M) = S1(M)+S(M)*WEIG(I1)
24344 170 CONTINUE
24345 180 CONTINUE
24346 S1(12) = S1(10)
24347 S1(13) = S1(11)
24348C quark charges fractions
24349 IF(IDPDG1.EQ.22) THEN
24350 CHRNF = 0.D0
24351 DO 100 I=1,NF
24352 CHRNF = CHRNF + Q_ch2(I)
24353 100 CONTINUE
24354 S1(11) = S1(11)*CHRNF
24355 ELSE IF(IDPDG1.EQ.990) THEN
24356 S1(11) = S1(11)*NF
24357 ELSE
24358 S1(11) = 0.D0
24359 ENDIF
24360 IF(IDPDG2.EQ.22) THEN
24361 CHRNF = 0.D0
24362 DO 200 I=1,NF
24363 CHRNF = CHRNF + Q_ch2(I)
24364 200 CONTINUE
24365 S1(13) = S1(13)*CHRNF
24366 ELSE IF(IDPDG2.EQ.990) THEN
24367 S1(13) = S1(13)*NF
24368 ELSE
24369 S1(13) = 0.D0
24370 ENDIF
24371 ENDIF
24372C
24373C global factors
24374 FFF = PI*GEV2MB*ALN*ALN/(AH*SS)
24375 DO 90 M=-1,Max_pro_2
24376 Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
2437790 CONTINUE
24378C
24379C double direct process
24380 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24381 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24382 FAC = 0.D0
24383 DO 300 I=1,NF
24384 IF(IDPDG1.EQ.22) THEN
24385 F1 = Q_ch2(I)
24386 ELSE
24387 F1 = 1.D0
24388 ENDIF
24389 IF(IDPDG2.EQ.22) THEN
24390 F2 = Q_ch2(I)
24391 ELSE
24392 F2 = 1.D0
24393 ENDIF
24394 FAC = FAC+F1*F2*3.D0
24395 300 CONTINUE
24396 ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24397 Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24398 & *GEV2MB*FAC
24399 ENDIF
24400 END
24401
24402*$ CREATE PHO_HARWGX.FOR
24403*COPY PHO_HARWGX
24404CDECK ID>, PHO_HARWGX
24405 SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24406C**********************************************************************
24407C
24408C find maximum of remaining weight for MC sampling
24409C
24410C input: PTCUT transverse momentum cutoff
24411C ECM cms energy
24412C
24413C output: HWgx(-1:Max_pro_2) field for sampling hard processes
24414C
24415C**********************************************************************
24416 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24417 SAVE
24418
24419 PARAMETER ( NKM = 10 )
24420 PARAMETER ( TINY = 1.D-20 )
24421
24422C input/output channels
24423 INTEGER LI,LO
24424 COMMON /POINOU/ LI,LO
24425C event debugging information
24426 INTEGER NMAXD
24427 PARAMETER (NMAXD=100)
24428 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24429 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24430 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24431 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24432C data on most recent hard scattering
24433 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24434 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24435 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24436 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24437 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24438 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24439 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24440 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24441 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24442C hard cross sections and MC selection weights
24443 INTEGER Max_pro_2
24444 PARAMETER ( Max_pro_2 = 16 )
24445 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24446 & MH_acc_1,MH_acc_2
24447 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24448 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24449 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24450 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24451 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24452 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24453
24454 DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24455 & XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24456 DIMENSION IFTAB(-1:Max_pro_2)
24457 DATA IFTAB / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24458
24459C initial settings
24460 AH = (2.D0*PTCUT/ECM)**2
24461 ALNH = LOG(AH)
24462 FF(0) = 0.D0
24463 DO 22 I=1,NKM
24464 FF(I) = 0.D0
24465 XM1(I) = 0.D0
24466 XM2(I) = 0.D0
24467 PTM(I) = 0.D0
24468 ZMX(1,I) = 0.D0
24469 ZMX(2,I) = 0.D0
24470 ZMX(3,I) = 0.D0
24471 DMX(1,I) = 0.D0
24472 DMX(2,I) = 0.D0
24473 DMX(3,I) = 0.D0
24474 IMX(I) = 0
24475 IPO(I) = 0
24476 22 CONTINUE
24477
24478 NKML = 10
24479 DO 40 NKON=1,NKML
24480
24481 DO 50 IST=1,3
24482C start configuration
24483 IF(IST.EQ.1) THEN
24484 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24485 Z(2) = 0.5
24486 Z(3) = 0.1
24487 D(1) =-0.5
24488 D(2) = 0.5
24489 D(3) = 0.5
24490 ELSE IF(IST.EQ.2) THEN
24491 Z(1) = 0.999D0
24492 Z(2) = 0.5
24493 Z(3) = 0.0
24494 D(1) =-0.5
24495 D(2) = 0.5
24496 D(3) = 0.5
24497 ELSE IF(IST.EQ.3) THEN
24498 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24499 Z(2) = 0.1
24500 Z(3) = 0.1
24501 D(1) =-0.5
24502 D(2) = 0.5
24503 D(3) = 0.5
24504 ELSE IF(IST.EQ.4) THEN
24505 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24506 Z(2) = 0.9
24507 Z(3) = 0.1
24508 D(1) =-0.5
24509 D(2) = 0.5
24510 D(3) = 0.5
24511 ENDIF
24512 IT = 0
24513 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24514C process possible?
24515 IF(F2.LE.0.D0) GOTO 35
24516
24517 10 CONTINUE
24518 IT = IT+1
24519 FOLD = F2
24520 DO 30 I=1,3
24521 D(I) = D(I)/5.D0
24522 Z(I) = Z(I)+D(I)
24523 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24524 IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24525 IF ( F2.GT.F3 ) D(I) =-D(I)
24526 20 CONTINUE
24527 F1 = MIN(F2,F3)
24528 F2 = MAX(F2,F3)
24529 Z(I) = Z(I)+D(I)
24530 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24531 IF ( F3.GT.F2 ) GOTO 20
24532 ZZ = Z(I)-D(I)
24533 Z(I) = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24534 IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24535 & CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24536 IF ( F1.LE.F2 ) Z(I) = ZZ
24537 F2 = MAX(F1,F2)
24538 30 CONTINUE
24539 IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24540
24541 IF(F2.GT.FF(NKON)) THEN
24542 FF(NKON) = MAX(F2,0.D0)
24543 XM1(NKON) = X1
24544 XM2(NKON) = X2
24545 PTM(NKON) = PT
24546 ZMX(1,NKON) = Z(1)
24547 ZMX(2,NKON) = Z(2)
24548 ZMX(3,NKON) = Z(3)
24549 DMX(1,NKON) = D(1)
24550 DMX(2,NKON) = D(2)
24551 DMX(3,NKON) = D(3)
24552 IMX(NKON) = IT
24553 IPO(NKON) = IST
24554 ENDIF
24555C
24556 50 CONTINUE
24557 35 CONTINUE
24558 40 CONTINUE
24559
24560C debug output
24561 IF(IDEB(38).GE.5) THEN
24562 WRITE(LO,'(/1X,A)')
24563 & 'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24564 DO 60 I=1,NKM
24565 IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24566 & IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24567 & DMX(2,I),DMX(3,I)
24568 60 CONTINUE
24569 ENDIF
24570
24571 DO 70 I=-1,Max_pro_2
24572 HWgx(I) = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24573 70 CONTINUE
24574
24575C debug output
24576 IF(IDEB(38).GE.5) THEN
24577 WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24578 WRITE(LO,'(5X,A)') 'I X1 X2 PT HWgx(I) FDIS'
24579 DO 80 I=-1,Max_pro_2
24580 IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24581 MSPR = I
24582 X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24583 X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24584 PT = PTM(IFTAB(I))
24585 CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24586 WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24587 ENDIF
24588 80 CONTINUE
24589 ENDIF
24590
24591 END
24592
24593*$ CREATE PHO_HARWGI.FOR
24594*COPY PHO_HARWGI
24595CDECK ID>, PHO_HARWGI
24596 SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24597C**********************************************************************
24598C
24599C auxiliary subroutine to find maximum of remaining weight
24600C
24601C input: ECMX current CMS energy
24602C PTCUT current pt cutoff
24603C NKON process label 1..5 resolved
24604C 6..7 direct particle 1
24605C 8..9 direct particle 2
24606C 10 double direct
24607C Z(3) transformed variable
24608C
24609C output: remaining weight
24610C
24611C**********************************************************************
24612 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24613 SAVE
24614
24615 DIMENSION Z(3)
24616
24617 PARAMETER ( NKM = 10 )
24618 PARAMETER ( TINY = 1.D-30,
24619 & TINY6 = 1.D-06 )
24620
24621C input/output channels
24622 INTEGER LI,LO
24623 COMMON /POINOU/ LI,LO
24624C event debugging information
24625 INTEGER NMAXD
24626 PARAMETER (NMAXD=100)
24627 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24628 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24629 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24630 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24631C model switches and parameters
24632 CHARACTER*8 MDLNA
24633 INTEGER ISWMDL,IPAMDL
24634 DOUBLE PRECISION PARMDL
24635 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24636C data of c.m. system of Pomeron / Reggeon exchange
24637 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24638 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24639 & SIDP,CODP,SIFP,COFP
24640 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24641 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24642 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24643C currently activated parton density parametrizations
24644 CHARACTER*8 PDFNAM
24645 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24646 DOUBLE PRECISION PDFLAM,PDFQ2M
24647 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24648 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24649C hard scattering parameters used for most recent hard interaction
24650 INTEGER NFbeta,NF
24651 DOUBLE PRECISION ALQCD2,BQCD
24652 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24653C some hadron information, will be deleted in future versions
24654 INTEGER NFS
24655 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24656 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24657C scale parameters for parton model calculations
24658 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24659 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24660 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24661 & NQQAL,NQQALI,NQQALF,NQQPD
24662C data on most recent hard scattering
24663 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24664 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24665 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24666 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24667 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24668 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24669 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24670 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24671 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24672
24673 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24674 DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24675
24676 FDIS = 0.D0
24677
24678 IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24679 & 'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24680C check input values
24681 IF ( Z(1).LT.0.D0 .OR. Z(1).GT.1.D0 ) RETURN
24682 IF ( Z(2).LT.0.D0 .OR. Z(2).GT.1.D0 ) RETURN
24683 IF ( Z(3).LT.0.D0 .OR. Z(3).GT.1.D0 ) RETURN
24684C transformations
24685 Y1 = EXP(ALNH*Z(1))
24686 IF(NKON.LE.5) THEN
24687C resolved kinematic
24688 Y2 =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24689 X1 = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24690 X2 = X1-Y2
24691 X1 = MIN(X1,0.999999999999D0)
24692 X2 = MIN(X2,0.999999999999D0)
24693 ELSE IF(NKON.LE.7) THEN
24694C direct kinematic 1
24695 X1 = 1.D0
24696 X2 = MIN(Y1,0.999999999999D0)
24697 ELSE IF(NKON.LE.9) THEN
24698C direct kinematic 2
24699 X1 = MIN(Y1,0.999999999999D0)
24700 X2 = 1.D0
24701 ELSE
24702C double direct kinematic
24703 X1 = 1.D0
24704 X2 = 1.D0
24705 ENDIF
24706 W = SQRT(MAX(TINY,1.D0-AH/Y1))
24707 V =-0.5D0+W*(Z(3)-0.5D0)
24708 U =-(1.D0+V)
24709 PT = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24710
24711C set hard scale QQ for alpha and partondistr.
24712 IF ( NQQAL.EQ.1 ) THEN
24713 QQAL = AQQAL*PT*PT
24714 ELSEIF ( NQQAL.EQ.2 ) THEN
24715 QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24716 ELSEIF ( NQQAL.EQ.3 ) THEN
24717 QQAL = AQQAL*Y1*ECMX*ECMX
24718 ELSEIF ( NQQAL.EQ.4 ) THEN
24719 QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24720 ENDIF
24721 IF ( NQQPD.EQ.1 ) THEN
24722 QQPD = AQQPD*PT*PT
24723 ELSEIF ( NQQPD.EQ.2 ) THEN
24724 QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24725 ELSEIF ( NQQPD.EQ.3 ) THEN
24726 QQPD = AQQPD*Y1*ECMX*ECMX
24727 ELSEIF ( NQQPD.EQ.4 ) THEN
24728 QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24729 ENDIF
24730C
24731 IF(NKON.LE.5) THEN
24732 DO 10 N=1,5
24733 F(N) = 0.D0
24734 10 CONTINUE
24735C resolved processes
24736 ALPHA1 = PHO_ALPHAS(QQAL,3)
24737 ALPHA2 = ALPHA1
24738 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24739 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24740C calculate full distribution FDIS
24741 DO 20 I=1,NF
24742 F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24743 F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24744 F(4) = F(4)+PDA(I)+PDA(-I)
24745 F(5) = F(5)+PDB(I)+PDB(-I)
2474620 CONTINUE
24747 F(1) = PDA(0)*PDB(0)
24748 T = PDA(0)*F(5)+PDB(0)*F(4)
24749 F(5) = F(4)*F(5)-(F(2)+F(3))
24750 F(4) = T
24751 ELSE IF(NKON.LE.7) THEN
24752C direct processes particle 1
24753 IF(IDPDG1.EQ.22) THEN
24754 ALPHA1 = pho_alphae(QQAL)
24755 CH1 = 4.D0/9.D0
24756 CH2 = 3.D0/9.D0
24757 ELSE IF(IDPDG1.EQ.990) THEN
24758 ALPHA1 = PARMDL(74)
24759 CH1 = 1.D0
24760 CH2 = 0.D0
24761 ELSE
24762 FDIS = -1.D0
24763 RETURN
24764 ENDIF
24765 ALPHA2 = PHO_ALPHAS(QQAL,2)
24766 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24767 F(6) = 0.D0
24768 DO 30 I=1,NF
24769 F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24770 30 CONTINUE
24771 F(7) = PDB(0)
24772 ELSE IF(NKON.LE.9) THEN
24773C direct processes particle 2
24774 ALPHA1 = PHO_ALPHAS(QQAL,1)
24775 IF(IDPDG2.EQ.22) THEN
24776 ALPHA2 = pho_alphae(QQAL)
24777 CH1 = 4.D0/9.D0
24778 CH2 = 3.D0/9.D0
24779 ELSE IF(IDPDG2.EQ.990) THEN
24780 ALPHA2 = PARMDL(74)
24781 CH1 = 1.D0
24782 CH2 = 0.D0
24783 ELSE
24784 FDIS = -1.D0
24785 RETURN
24786 ENDIF
24787 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24788 F(8) = 0.D0
24789 DO 40 I=1,NF
24790 F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24791 40 CONTINUE
24792 F(9) = PDA(0)
24793 ELSE
24794C double direct process
24795 SSR = ECMX*ECMX
24796 IF(IDPDG1.EQ.22) THEN
24797 ALPHA1 = pho_alphae(SSR)
24798 ELSE IF(IDPDG1.EQ.990) THEN
24799 ALPHA1 = PARMDL(74)
24800 ELSE
24801 FDIS = -1.D0
24802 RETURN
24803 ENDIF
24804 IF(IDPDG2.EQ.22) THEN
24805 ALPHA2 = pho_alphae(SSR)
24806 ELSE IF(IDPDG2.EQ.990) THEN
24807 ALPHA2 = PARMDL(74)
24808 ELSE
24809 FDIS = -1.D0
24810 RETURN
24811 ENDIF
24812 F(10) = 1.D0
24813 ENDIF
24814
24815 FDIS = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24816
24817C debug output
24818 IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24819 & 'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24820 & NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24821
24822 END
24823
24824*$ CREATE PHO_HARINI.FOR
24825*COPY PHO_HARINI
24826CDECK ID>, PHO_HARINI
24827 SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24828C**********************************************************************
24829C
24830C initialize calculation of hard cross section
24831C
24832C must not be called during MC generation
24833C
24834C***********************************************************************
24835 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24836 SAVE
24837
24838 PARAMETER ( DEPS = 1.D-10 )
24839
24840C input/output channels
24841 INTEGER LI,LO
24842 COMMON /POINOU/ LI,LO
24843C event debugging information
24844 INTEGER NMAXD
24845 PARAMETER (NMAXD=100)
24846 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24847 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24848 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24849 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24850C model switches and parameters
24851 CHARACTER*8 MDLNA
24852 INTEGER ISWMDL,IPAMDL
24853 DOUBLE PRECISION PARMDL
24854 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24855C currently activated parton density parametrizations
24856 CHARACTER*8 PDFNAM
24857 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24858 DOUBLE PRECISION PDFLAM,PDFQ2M
24859 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24860 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24861C some constants
24862 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24863 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24864 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24865C scale parameters for parton model calculations
24866 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24867 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24868 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24869 & NQQAL,NQQALI,NQQALF,NQQPD
24870C data of c.m. system of Pomeron / Reggeon exchange
24871 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24872 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24873 & SIDP,CODP,SIFP,COFP
24874 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24875 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24876 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24877C obsolete cut-off information
24878 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24879 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24880C hard scattering parameters used for most recent hard interaction
24881 INTEGER NFbeta,NF
24882 DOUBLE PRECISION ALQCD2,BQCD
24883 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24884
24885 double precision pho_alphas
24886
24887 CHARACTER*20 RFLAG
24888
24889C set local Pomeron c.m. system data
24890 IDPDG1 = IDP1
24891 IDPDG2 = IDP2
24892 PVIRTP(1) = PV1
24893 PVIRTP(2) = PV2
24894C initialize PDFs
24895 CALL PHO_ACTPDF(IDPDG1,1)
24896 CALL PHO_ACTPDF(IDPDG2,2)
24897C initialize alpha_s calculation
24898 DUMMY = PHO_ALPHAS(0.D0,-4)
24899C initialize scales with defaults
24900 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24901 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24902 AQQAL = PARMDL(83)
24903 AQQALI = PARMDL(86)
24904 AQQALF = PARMDL(89)
24905 AQQPD = PARMDL(92)
24906 NQQAL = IPAMDL(83)
24907 NQQALI = IPAMDL(86)
24908 NQQALF = IPAMDL(89)
24909 NQQPD = IPAMDL(92)
24910 ELSE
24911 AQQAL = PARMDL(82)
24912 AQQALI = PARMDL(85)
24913 AQQALF = PARMDL(88)
24914 AQQPD = PARMDL(91)
24915 NQQAL = IPAMDL(82)
24916 NQQALI = IPAMDL(85)
24917 NQQALF = IPAMDL(88)
24918 NQQPD = IPAMDL(91)
24919 ENDIF
24920 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24921 AQQAL = PARMDL(82)
24922 AQQALI = PARMDL(85)
24923 AQQALF = PARMDL(88)
24924 AQQPD = PARMDL(91)
24925 NQQAL = IPAMDL(82)
24926 NQQALI = IPAMDL(85)
24927 NQQALF = IPAMDL(88)
24928 NQQPD = IPAMDL(91)
24929 ELSE
24930 AQQAL = PARMDL(81)
24931 AQQALI = PARMDL(84)
24932 AQQALF = PARMDL(87)
24933 AQQPD = PARMDL(90)
24934 NQQAL = IPAMDL(81)
24935 NQQALI = IPAMDL(84)
24936 NQQALF = IPAMDL(87)
24937 NQQPD = IPAMDL(90)
24938 ENDIF
24939 IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24940 IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24941 IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24942 IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24943 IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24944 IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24945 IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24946 IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24947 AQQAL = PARMDL(109+IP)
24948 AQQALI = PARMDL(113+IP)
24949 AQQALF = PARMDL(117+IP)
24950 AQQPD = PARMDL(121+IP)
24951 NQQAL = IPAMDL(64+IP)
24952 NQQALI = IPAMDL(68+IP)
24953 NQQALF = IPAMDL(72+IP)
24954 NQQPD = IPAMDL(76+IP)
24955 PTCUT(1) = PARMDL(36)
24956 PTCUT(2) = PARMDL(37)
24957 PTCUT(3) = PARMDL(38)
24958 PTCUT(4) = PARMDL(39)
24959 PTANO(1) = PARMDL(130)
24960 PTANO(2) = PARMDL(131)
24961 PTANO(3) = PARMDL(132)
24962 PTANO(4) = PARMDL(133)
24963 RFLAG = '(energy-independent)'
24964 IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24965
24966C write out all settings
24967 IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24968 WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24969 & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24970 & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24971 & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
249721050 FORMAT(/,
24973 & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24974 & 5X,'particle 1 / particle 2:',2I8,/,
24975 & 5X,'min. PT :',F7.1,2X,A,/,
24976 & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24977 & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24978 & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24979 & 5X,'max. number of active flavours NF :',I3,/,
24980 & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24981 ENDIF
24982
24983 END
24984
24985*$ CREATE PHO_HARINT.FOR
24986*COPY PHO_HARINT
24987CDECK ID>, PHO_HARINT
24988 SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24989C**********************************************************************
24990C
24991C interpolate cross sections and weights for hard scattering
24992C
24993C input: IPP particle combination (neg. for add. user cuts)
24994C ECM CMS energy (GeV)
24995C P2V1/2 particle virtualities (pos., GeV**2)
24996C I1 first subprocess to calculate
24997C I2 last subprocess to calculate
24998C <-1 only scales and cutoffs calculated
24999C K1 first variable to calculate
25000C K2 last variable to calculate
25001C MSPOM cross sections to use for pt distribution
25002C 0 reggeon
25003C >0 pomeron
25004C
25005C for K1 < 3 the soft pt distribution is also calculated
25006C
25007C output: interpolated values in HWgx, HSig, Hdpt
25008C
25009C***********************************************************************
25010 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25011 SAVE
25012
25013 PARAMETER ( DEPS = 1.D-15,
25014 & DEPS2 = 2.D-15 )
25015
25016C input/output channels
25017 INTEGER LI,LO
25018 COMMON /POINOU/ LI,LO
25019C event debugging information
25020 INTEGER NMAXD
25021 PARAMETER (NMAXD=100)
25022 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25023 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25024 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25025 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25026C model switches and parameters
25027 CHARACTER*8 MDLNA
25028 INTEGER ISWMDL,IPAMDL
25029 DOUBLE PRECISION PARMDL
25030 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25031C Reggeon phenomenology parameters
25032 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25033 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25034 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25035 & ALREG,ALREGP,GR(2),B0REG(2),
25036 & GPPP,GPPR,B0PPP,B0PPR,
25037 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25038C parameters of 2x2 channel model
25039 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
25040 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
25041C data needed for soft-pt calculation
25042 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
25043 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
25044C scale parameters for parton model calculations
25045 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25046 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25047 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25048 & NQQAL,NQQALI,NQQALF,NQQPD
25049C obsolete cut-off information
25050 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25051 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25052C event weights and generated cross section
25053 INTEGER IPOWGC,ISWCUT,IVWGHT
25054 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25055 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25056 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25057C parameters for DGLAP backward evolution in ISR
25058 INTEGER NFSISR
25059 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
25060 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
25061C hard cross sections and MC selection weights
25062 INTEGER Max_pro_2
25063 PARAMETER ( Max_pro_2 = 16 )
25064 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25065 & MH_acc_1,MH_acc_2
25066 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25067 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25068 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25069 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25070 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25071 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25072C interpolation tables for hard cross section and MC selection weights
25073 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25074 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25075 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25076 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25077 & HQ2a_tab,HQ2b_tab,HEcm_tab
25078 COMMON /POHTAB/
25079 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25080 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25081 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25082 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25083 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25084 & HEcm_tab(1:Max_tab_E,0:4),
25085 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25086C data on most recent hard scattering
25087 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
25088 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
25089 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
25090 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
25091 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
25092 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
25093 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
25094 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
25095 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
25096C energy-interpolation table
25097 INTEGER IEETA2
25098 PARAMETER ( IEETA2 = 20 )
25099 INTEGER ISIMAX
25100 DOUBLE PRECISION SIGTAB,SIGECM
25101 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
25102
25103 DOUBLE PRECISION XP,PTS
25104 DIMENSION XP(2),PTS(0:2,2)
25105
25106 INTEGER IV
25107 DIMENSION IV(2)
25108
25109 IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
25110 & 'PHO_HARINT: called with ',
25111 & 'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
25112 & IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
25113
25114 IP = ABS(IPP)
25115 IF(IPP.GT.0) THEN
25116C default minimum bias cutoff
25117 PTCUT(IP) = pho_ptcut(ECM,IP)
25118 ELSE
25119C user defined additional cutoff
25120 PTCUT(IP) = HSWCUT(4+IP)
25121 ENDIF
25122 PTWANT = PTCUT(IP)
25123
25124C ISR cutoffs
25125 Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
25126 Q2MISR(1) = MAX(P2V1,Q2CUT)
25127 Q2MISR(2) = MAX(P2V2,Q2CUT)
25128C cutoff for direct photon contribution to photon PDF
25129 PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
25130 PTA1 = PTANO(IP)
25131C scales for hard scattering
25132 AQQAL = PARMDL(109+IP)
25133 AQQALI = PARMDL(113+IP)
25134 AQQALF = PARMDL(117+IP)
25135 AQQPD = PARMDL(121+IP)
25136 NQQAL = IPAMDL(64+IP)
25137 NQQALI = IPAMDL(68+IP)
25138 NQQALF = IPAMDL(72+IP)
25139 NQQPD = IPAMDL(76+IP)
25140 IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
25141 & 'PHO_HARINT: scales:',
25142 & NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
25143
25144 IF(I2.LT.-1) RETURN
25145
25146 IL = IP
25147 IF(IPP.LT.0) IL = 0
25148
25149C double-log interpolation
25150 IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
25151 DO 50 M=I1,I2
25152 Hfac(M) = 0.D0
25153 HWgx(M) = 0.D0
25154 HSig(M) = 0.D0
25155 Hdpt(M) = 0.D0
25156 50 CONTINUE
25157 ELSE
25158 I=1
25159 310 CONTINUE
25160 I = I+1
25161 IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
25162
25163 Ia = 1
25164 Ib = 1
25165 fac = LOG(ECM/HEcm_tab(I-1,IL))
25166 & /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
25167 do M=I1,I2
25168C factor due to phase space integration
25169 XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25170 & *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
25171 & /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
25172 XX = EXP(XX)
25173 IF(XX.LT.DEPS2) XX = 0.D0
25174 Hfac(M) = XX
25175C max. weight
25176 XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25177 & *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
25178 & /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
25179 XX = EXP(XX)
25180 IF(XX.LT.DEPS2) XX = 0.D0
25181 HWgx(M) = XX*1.2D0
25182C hard cross section
25183 XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25184 & *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
25185 & /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
25186 XX = EXP(XX)
25187 IF(XX.LT.DEPS2) XX = 0.D0
25188 HSig(M) = XX
25189C differential hard cross section
25190 XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25191 & *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
25192 & /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
25193 XX = EXP(XX)
25194 IF(XX.LT.DEPS2) XX = 0.D0
25195 Hdpt(M) = XX
25196 enddo
25197 ENDIF
25198
25199 IF((K1.LT.3).AND.(K2.GE.3)) THEN
25200C cross check
25201 IF((I1.GT.9).OR.(I2.LT.9)) THEN
25202 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
25203 & 'hard cross section not calculated ',I1,I2
25204 ENDIF
25205 SIGH = HSig(9)
25206 DSIGHP = Hdpt(9)
25207C load soft cross sections from interpolation table
25208 IF(ECM.LE.SIGECM(IP,1)) THEN
25209 L1 = 1
25210 L2 = 1
25211 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
25212 DO 55 I=2,ISIMAX
25213 IF(ECM.LE.SIGECM(IP,I)) GOTO 205
25214 55 CONTINUE
25215 205 CONTINUE
25216 L1 = I-1
25217 L2 = I
25218 ELSE
25219 WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
25220 & 'PHO_HARINT: energy too high (IP,Ecm,Emax)',
25221 & IP,ECM,SIGECM(IP,ISIMAX)
25222 CALL PHO_PREVNT(-1)
25223 L1 = ISIMAX-1
25224 L2 = ISIMAX
25225 ENDIF
25226 FAC2=0.D0
25227 IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
25228 & /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
25229 FAC1=1.D0-FAC2
25230 SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
25231 & FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
25232
25233 FS = FPS(IP)
25234 FH = FPH(IP)
25235 CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
25236 ENDIF
25237
25238 300 CONTINUE
25239
25240C debug output
25241 IF(IDEB(58).GE.15) THEN
25242 WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25243 & 'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25244 & KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25245 DO 162 M=I1,I2
25246 WRITE(LO,'(5X,2I3,1p,4E12.3)')
25247 & M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25248 162 CONTINUE
25249 ENDIF
25250
25251 END
25252
25253*$ CREATE PHO_PTCUT.FOR
25254*COPY PHO_PTCUT
25255 DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25256C***********************************************************************
25257C
25258C calculate energy-dependent transverse momentum cutoff
25259C
25260C***********************************************************************
25261
25262 IMPLICIT NONE
25263
25264 SAVE
25265
25266 double precision ECM
25267 integer IP
25268
25269C input/output channels
25270 INTEGER LI,LO
25271 COMMON /POINOU/ LI,LO
25272C event debugging information
25273 INTEGER NMAXD
25274 PARAMETER (NMAXD=100)
25275 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25276 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25277 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25278 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25279C model switches and parameters
25280 CHARACTER*8 MDLNA
25281 INTEGER ISWMDL,IPAMDL
25282 DOUBLE PRECISION PARMDL
25283 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25284
25285 pho_ptcut = PARMDL(35+IP)
25286
25287 IF(IPAMDL(7).EQ.1) THEN
25288C Bopp et al. type (DPMJET)
25289 pho_ptcut = PARMDL(35+IP)
25290 & + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25291 ELSE IF(IPAMDL(7).EQ.2) THEN
25292C Gribov-Levin-Ryskin type
25293 pho_ptcut = PARMDL(35+IP)
25294 & + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25295 ENDIF
25296
25297 END
25298
25299*$ CREATE PHO_HARMCI.FOR
25300*COPY PHO_HARMCI
25301CDECK ID>, PHO_HARMCI
25302 SUBROUTINE PHO_HARMCI(IP,EMAXF)
25303C**********************************************************************
25304C
25305C initialize MC sampling and calculate hard cross section
25306C
25307C input: IP particle combination (neg. number for user cut)
25308C EMAXF maximum CMS energy for
25309C interpolation table in reference to PTCUT(1..4)
25310C
25311C***********************************************************************
25312 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25313 SAVE
25314
25315 PARAMETER (DEPS = 1.D-10,
25316 & PLARGE = 1.D20 )
25317
25318C input/output channels
25319 INTEGER LI,LO
25320 COMMON /POINOU/ LI,LO
25321C event debugging information
25322 INTEGER NMAXD
25323 PARAMETER (NMAXD=100)
25324 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25325 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25326 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25327 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25328C some constants
25329 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25330 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25331 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25332C global event kinematics and particle IDs
25333 INTEGER IFPAP,IFPAB
25334 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25335 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25336C data of c.m. system of Pomeron / Reggeon exchange
25337 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25338 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25339 & SIDP,CODP,SIFP,COFP
25340 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25341 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25342 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25343C model switches and parameters
25344 CHARACTER*8 MDLNA
25345 INTEGER ISWMDL,IPAMDL
25346 DOUBLE PRECISION PARMDL
25347 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25348C obsolete cut-off information
25349 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25350 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25351C scale parameters for parton model calculations
25352 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25353 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25354 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25355 & NQQAL,NQQALI,NQQALF,NQQPD
25356C names of hard scattering processes
25357 INTEGER Max_pro_1
25358 PARAMETER ( Max_pro_1 = 16 )
25359 CHARACTER*18 PROC
25360 COMMON /POHPRO/ PROC(0:Max_pro_1)
25361C hard cross sections and MC selection weights
25362 INTEGER Max_pro_2
25363 PARAMETER ( Max_pro_2 = 16 )
25364 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25365 & MH_acc_1,MH_acc_2
25366 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25367 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25368 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25369 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25370 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25371 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25372C interpolation tables for hard cross section and MC selection weights
25373 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25374 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25375 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25376 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25377 & HQ2a_tab,HQ2b_tab,HEcm_tab
25378 COMMON /POHTAB/
25379 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25380 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25381 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25382 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25383 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25384 & HEcm_tab(1:Max_tab_E,0:4),
25385 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25386C event weights and generated cross section
25387 INTEGER IPOWGC,ISWCUT,IVWGHT
25388 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25389 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25390 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25391
25392 COMPLEX*16 DSIG
25393 DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25394
25395C initialization for all pt cutoffs
25396 I = ABS(IP)
25397 IL = I
25398 IF(IP.LT.0) THEN
25399 IL = 0
25400 PTC = HSWCUT(4+I)
25401 else
25402 PTC = pho_ptcut(parmdl(19),I)
25403 ENDIF
25404
25405C skip unassigned PTCUT
25406 IF(PTC.LT.0.5D0) GOTO 1000
25407
25408 IH_Q2a_up(I) = 1
25409 IH_Q2b_up(I) = 1
25410 do ib=1,Max_tab_Q2
25411 do ia=1,Max_tab_Q2
25412 do ie=1,Max_tab_E
25413 do m=-1,Max_pro_2
25414 Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25415 HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25416 HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25417 Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25418 enddo
25419 enddo
25420 enddo
25421 enddo
25422
25423 ELLOW = LOG(2.05*PTC)
25424 DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25425C energy too low
25426 IF(DELTA.LE.0.D0) GOTO 1000
25427
25428C switch between external particles and Pomeron
25429 IF(I.EQ.4) THEN
25430 IDP1 = 990
25431 PV1 = 0.D0
25432 IDP2 = 990
25433 PV2 = 0.D0
25434 ELSE IF(I.EQ.3) THEN
25435 IDP1 = IFPAP(2)
25436 PV1 = PVIRT(2)
25437 IDP2 = 990
25438 PV2 = 0.D0
25439 ELSE IF(I.EQ.2) THEN
25440 IDP1 = IFPAP(1)
25441 PV1 = PVIRT(1)
25442 IDP2 = 990
25443 PV2 = 0.D0
25444 ELSE
25445 IDP1 = IFPAP(1)
25446 PV1 = PVIRT(1)
25447 IDP2 = IFPAP(2)
25448 PV2 = PVIRT(2)
25449 ENDIF
25450
25451C initialize PT scales
25452 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25453 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25454 FPS(I) = PARMDL(105)
25455 FPH(I) = PARMDL(106)
25456 ELSE
25457 FPS(I) = PARMDL(103)
25458 FPH(I) = PARMDL(104)
25459 ENDIF
25460 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25461 FPS(I) = PARMDL(103)
25462 FPH(I) = PARMDL(104)
25463 ELSE
25464 FPS(I) = PARMDL(101)
25465 FPH(I) = PARMDL(102)
25466 ENDIF
25467
25468C initialize hard scattering
25469 IF(IP.GT.0) THEN
25470 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25471 ELSE
25472 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25473 ENDIF
25474
25475C energy/virtuality grid
25476 do Ie=1,IH_Ecm_up(IL)
25477 HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25478 enddo
25479 do Ia=1,IH_Q2a_up(IL)
25480 HQ2a_tab(Ia,IL) = 0.D0
25481 enddo
25482 do Ib=1,IH_Q2b_up(IL)
25483 HQ2b_tab(Ib,IL) = 0.D0
25484 enddo
25485
25486C initialization for several energies and particle virtualities
25487 do Ie=1,IH_Ecm_up(IL)
25488 do Ia=1,IH_Q2a_up(IL)
25489 do Ib=1,IH_Q2b_up(IL)
25490
25491 EE = HEcm_tab(IE,IL)
25492 Q2a = HQ2a_tab(Ia,IL)
25493 Q2b = HQ2b_tab(Ib,IL)
25494 CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25495 IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25496 & 'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25497 & PTCUT(I),EE,IDPDG1,IDPDG2
25498 Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25499 CALL PHO_HARFAC(PTCUT(I),EE)
25500 CALL PHO_HARWGX(PTCUT(I),EE)
25501 CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25502 IF(IDEB(8).GE.10) THEN
25503 WRITE(LO,'(1X,A,/,1X,A)')
25504 & 'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25505 & '------------------------------------------------'
25506 DO M=0,Max_pro_2
25507 WRITE(LO,'(10X,A,1P2E14.4)')
25508 & PROC(M),DREAL(DSIG(M)),DSPT(M)
25509 ENDDO
25510 ENDIF
25511
25512C store in interpolation tables
25513 Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25514 HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25515 do M=0,Max_pro_2
25516 Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25517 HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25518 HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25519 Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25520 enddo
25521
25522C summed quantities
25523 HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25524 Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25525 do M=1,8
25526 IF(MH_pro_on(M,I).GT.0) THEN
25527 HSig_tab(9,IE,Ia,Ib,IL) =
25528 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25529 Hdpt_tab(9,IE,Ia,Ib,IL) =
25530 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25531 ENDIF
25532 enddo
25533 HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25534 Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25535 do M=10,14
25536 IF(MH_pro_on(M,I).GT.0) THEN
25537 HSig_tab(15,IE,Ia,Ib,IL) =
25538 & HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25539 Hdpt_tab(15,IE,Ia,Ib,IL) =
25540 & Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25541 ENDIF
25542 enddo
25543 HSig_tab(0,IE,Ia,Ib,IL) =
25544 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25545 Hdpt_tab(0,IE,Ia,Ib,IL) =
25546 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25547
25548 enddo
25549 enddo
25550 enddo
25551
25552C debug output of weights
25553 1000 CONTINUE
25554 IF(IDEB(8).GE.5) THEN
25555 WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25556 & 'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25557 & IDPDG1,IDPDG2,IP,PTCUT(I),
25558 & '------------------------------------------'
25559 DO M=-1,Max_pro_2
25560 IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25561 WRITE(LO,'(2X,A,I3,2I7)')
25562 & 'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25563 & M,IDPDG1,IDPDG2
25564 do k=1,IH_Ecm_up(IL)
25565 do ia=1,IH_Q2a_up(IL)
25566 do ib=1,IH_Q2b_up(IL)
25567 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25568 & HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25569 & Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25570 & HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25571 enddo
25572 enddo
25573 enddo
25574 512 CONTINUE
25575 ENDDO
25576 ENDIF
25577
25578 END
25579
25580*$ CREATE PHO_HARXR3.FOR
25581*COPY PHO_HARXR3
25582CDECK ID>, PHO_HARXR3
25583 SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25584C**********************************************************************
25585C
25586C differential cross section DSIG/(DETAC*DETAD*DPT)
25587C
25588C input: ECMH CMS energy
25589C PT parton PT
25590C ETAC pseudorapidity of parton C
25591C ETAD pseudorapidity of parton D
25592C
25593C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25594C
25595C**********************************************************************
25596 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25597 SAVE
25598
25599 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25600
25601 PARAMETER ( Max_pro_2 = 16 )
25602 COMPLEX*16 DSIGMC
25603 DIMENSION DSIGMC(0:Max_pro_2)
25604 DIMENSION DSIGM(0:Max_pro_2)
25605
25606C input/output channels
25607 INTEGER LI,LO
25608 COMMON /POINOU/ LI,LO
25609C some constants
25610 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25611 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25612 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25613C Reggeon phenomenology parameters
25614 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25615 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25616 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25617 & ALREG,ALREGP,GR(2),B0REG(2),
25618 & GPPP,GPPR,B0PPP,B0PPR,
25619 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25620C currently activated parton density parametrizations
25621 CHARACTER*8 PDFNAM
25622 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25623 DOUBLE PRECISION PDFLAM,PDFQ2M
25624 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25625 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25626C hard scattering parameters used for most recent hard interaction
25627 INTEGER NFbeta,NF
25628 DOUBLE PRECISION ALQCD2,BQCD
25629 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25630C scale parameters for parton model calculations
25631 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25632 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25633 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25634 & NQQAL,NQQALI,NQQALF,NQQPD
25635
25636 DOUBLE PRECISION PHO_ALPHAS
25637 DIMENSION PDA(-6:6),PDB(-6:6)
25638
25639 DO 10 I=1,9
25640 DSIGMC(I) = CMPLX(0.D0,0.D0)
25641 DSIGM(I) = 0.D0
2564210 CONTINUE
25643
25644 EC = EXP(ETAC)
25645 ED = EXP(ETAD)
25646C kinematic conversions
25647 XA = PT*(EC+ED)/ECMH
25648 XB = XA/(EC*ED)
25649 IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25650 WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25651 RETURN
25652 ENDIF
25653 SP = XA*XB*ECMH*ECMH
25654 UP =-ECMH*PT*EC*XB
25655 UP = UP/SP
25656 TP =-(1.D0+UP)
25657 UU = UP*UP
25658 TT = TP*TP
25659C set hard scale QQ for alpha and partondistr.
25660 IF ( NQQAL.EQ.1 ) THEN
25661 QQAL = AQQAL*PT*PT
25662 ELSEIF ( NQQAL.EQ.2 ) THEN
25663 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25664 ELSEIF ( NQQAL.EQ.3 ) THEN
25665 QQAL = AQQAL*SP
25666 ELSEIF ( NQQAL.EQ.4 ) THEN
25667 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25668 ENDIF
25669 IF ( NQQPD.EQ.1 ) THEN
25670 QQPD = AQQPD*PT*PT
25671 ELSEIF ( NQQPD.EQ.2 ) THEN
25672 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25673 ELSEIF ( NQQPD.EQ.3 ) THEN
25674 QQPD = AQQPD*SP
25675 ELSEIF ( NQQPD.EQ.4 ) THEN
25676 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25677 ENDIF
25678
25679 ALPHA = PHO_ALPHAS(QQAL,3)
25680 FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25681C parton distributions (times x)
25682 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25683 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25684 S1 = PDA(0)*PDB(0)
25685 S2 = 0.D0
25686 S3 = 0.D0
25687 S4 = 0.D0
25688 S5 = 0.D0
25689 DO 20 I=1,NF
25690 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25691 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25692 S4 = S4+PDA(I)+PDA(-I)
25693 S5 = S5+PDB(I)+PDB(-I)
2569420 CONTINUE
25695C partial cross sections (including color and symmetry factors)
25696C resolved photon matrix elements (light quarks)
25697 DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25698 DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25699 DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25700 DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25701 DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25702 DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25703 DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25704 DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25705 & (8.D0/27.D0)/(UP*TP))
25706C
25707 DSIGM(1) = FACTOR*DSIGM(1)*S1
25708 DSIGM(2) = FACTOR*DSIGM(2)*S2
25709 DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25710 DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25711 DSIGM(5) = FACTOR*DSIGM(5)*S2
25712 DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25713 DSIGM(7) = FACTOR*DSIGM(7)*S3
25714 DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25715C complex part
25716 X=ABS(TP-UP)
25717 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25718C
25719 DO 50 I=1,8
25720 IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25721 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25722 DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25723 50 CONTINUE
25724 END
25725
25726*$ CREATE PHO_HARXR2.FOR
25727*COPY PHO_HARXR2
25728CDECK ID>, PHO_HARXR2
25729 SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25730C**********************************************************************
25731C
25732C differential cross section DSIG/(DETAC*DPT)
25733C
25734C input: ECMH CMS energy
25735C PT parton PT
25736C ETAC pseudorapidity of parton C
25737C
25738C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25739C
25740C**********************************************************************
25741 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25742 SAVE
25743
25744 PARAMETER ( TINY= 1.D-20 )
25745
25746 PARAMETER ( Max_pro_2 = 16 )
25747 COMPLEX*16 DSIGMC
25748 DIMENSION DSIGMC(0:Max_pro_2)
25749
25750C input/output channels
25751 INTEGER LI,LO
25752 COMMON /POINOU/ LI,LO
25753C integration precision for hard cross sections (obsolete)
25754 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25755 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25756
25757 COMPLEX*16 DSIG1
25758 DIMENSION DSIG1(0:Max_pro_2)
25759 DIMENSION ABSZ(32),WEIG(32)
25760
25761 DO 10 M=1,9
25762 DSIGMC(M) = CMPLX(0.D0,0.D0)
25763 DSIG1(M) = 0.D0
2576410 CONTINUE
25765C
25766 EC = EXP(ETAC)
25767 ARG = ECMH/PT
25768 IF ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25769 EDU = LOG(ARG-EC)
25770 EDL =-LOG(ARG-1.D0/EC)
25771 NPOINT = NGAUET
25772 CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25773 DO 30 I=1,NPOINT
25774 CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25775 DO 20 M=1,9
25776 PCTRL= DREAL(DSIG1(M))/TINY
25777 IF( PCTRL.GE.1.D0 ) THEN
25778 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25779 ENDIF
2578020 CONTINUE
2578130 CONTINUE
25782 END
25783
25784*$ CREATE PHO_HARXD2.FOR
25785*COPY PHO_HARXD2
25786CDECK ID>, PHO_HARXD2
25787 SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25788C**********************************************************************
25789C
25790C differential cross section DSIG/(DETAC*DPT) for direct processes
25791C
25792C input: ECMH CMS energy of scattering system
25793C PT parton PT
25794C ETAC pseudorapidity of parton C
25795C
25796C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25797C
25798C**********************************************************************
25799 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25800 SAVE
25801
25802 PARAMETER ( Max_pro_2 = 16 )
25803 COMPLEX*16 DSIGMC
25804 DIMENSION DSIGMC(0:Max_pro_2)
25805 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25806
25807C input/output channels
25808 INTEGER LI,LO
25809 COMMON /POINOU/ LI,LO
25810C model switches and parameters
25811 CHARACTER*8 MDLNA
25812 INTEGER ISWMDL,IPAMDL
25813 DOUBLE PRECISION PARMDL
25814 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25815C data of c.m. system of Pomeron / Reggeon exchange
25816 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25817 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25818 & SIDP,CODP,SIFP,COFP
25819 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25820 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25821 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25822C Reggeon phenomenology parameters
25823 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25824 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25825 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25826 & ALREG,ALREGP,GR(2),B0REG(2),
25827 & GPPP,GPPR,B0PPP,B0PPR,
25828 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25829C currently activated parton density parametrizations
25830 CHARACTER*8 PDFNAM
25831 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25832 DOUBLE PRECISION PDFLAM,PDFQ2M
25833 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25834 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25835C hard scattering parameters used for most recent hard interaction
25836 INTEGER NFbeta,NF
25837 DOUBLE PRECISION ALQCD2,BQCD
25838 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25839C some hadron information, will be deleted in future versions
25840 INTEGER NFS
25841 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25842 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25843C scale parameters for parton model calculations
25844 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25845 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25846 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25847 & NQQAL,NQQALI,NQQALF,NQQPD
25848C some constants
25849 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25850 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25851 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25852
25853 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25854 DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25855
25856* ONE32=1.D0/9.D0
25857* TWO32=4.D0/9.D0
25858 DO 10 I=10,13
25859 DSIGMC(I) = CMPLX(0.D0,0.D0)
25860 DSIGM(I) = 0.D0
25861 10 CONTINUE
25862 DSIGMC(15) = CMPLX(0.D0,0.D0)
25863 DSIGM(15) = 0.D0
25864
25865C direct particle 1
25866 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25867 EC = EXP(ETAC)
25868 ED = ECMH/PT-EC
25869C kinematic conversions
25870 XA = 1.D0
25871 XB = 1.D0/(EC*ED)
25872 IF ( XB.GE.1.D0 ) THEN
25873 WRITE(LO,'(/1X,A,2E12.4)')
25874 & 'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25875 RETURN
25876 ENDIF
25877 SP = XA*XB*ECMH*ECMH
25878 UP =-ECMH*PT*EC*XB
25879 UP = UP/SP
25880 TP =-(1.D0+UP)
25881 UU = UP*UP
25882 TT = TP*TP
25883C set hard scale QQ for alpha and partondistr.
25884 IF ( NQQAL.EQ.1 ) THEN
25885 QQAL = AQQAL*PT*PT
25886 ELSEIF ( NQQAL.EQ.2 ) THEN
25887 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25888 ELSEIF ( NQQAL.EQ.3 ) THEN
25889 QQAL = AQQAL*SP
25890 ELSEIF ( NQQAL.EQ.4 ) THEN
25891 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25892 ENDIF
25893 IF ( NQQPD.EQ.1 ) THEN
25894 QQPD = AQQPD*PT*PT
25895 ELSEIF ( NQQPD.EQ.2 ) THEN
25896 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25897 ELSEIF ( NQQPD.EQ.3 ) THEN
25898 QQPD = AQQPD*SP
25899 ELSEIF ( NQQPD.EQ.4 ) THEN
25900 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25901 ENDIF
25902
25903 ALPHA2 = PHO_ALPHAS(QQAL,2)
25904 IF(IDPDG1.EQ.22) THEN
25905 ALPHA1 = pho_alphae(QQAL)
25906 ELSE IF(IDPDG1.EQ.990) THEN
25907 ALPHA1 = PARMDL(74)
25908 ENDIF
25909 FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25910C parton distribution (times x)
25911 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25912 S1 = PDB(0)
25913C charge counting
25914 S2 = 0.D0
25915 S3 = 0.D0
25916 IF(IDPDG1.EQ.22) THEN
25917 DO 20 I=1,NF
25918* IF(MOD(I,2).EQ.0) THEN
25919* S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25920* S3 = S3 + TWO32
25921* ELSE
25922* S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25923* S3 = S3 + ONE32
25924* ENDIF
25925 S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25926 S3 = S3 + Q_ch2(I)
25927 20 CONTINUE
25928 ELSE IF(IDPDG1.EQ.990) THEN
25929 DO 25 I=1,NF
25930 S2 = S2 + PDB(I)+PDB(-I)
25931 25 CONTINUE
25932 S3 = NF
25933 ENDIF
25934C partial cross sections (including color and symmetry factors)
25935C direct photon matrix elements
25936 DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25937 DSIGM(11) = (UU+TT)/(UP*TP)
25938C
25939 DSIGM(10) = FACTOR*DSIGM(10)*S2
25940 DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25941C complex part
25942 X=ABS(TP-UP)
25943 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25944C
25945 DO 50 I=10,11
25946 IF(DSIGM(I).LT.0.D0) THEN
25947 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25948 & 'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25949 DSIGM(I) = 0.D0
25950 ENDIF
25951 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25952 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25953 50 CONTINUE
25954 ENDIF
25955C
25956C direct particle 2
25957 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25958 EC = EXP(ETAC)
25959 ED = 1.D0/(ECMH/PT-1.D0/EC)
25960C kinematic conversions
25961 XA = PT*(EC+ED)/ECMH
25962 XB = 1.D0
25963 IF ( XA.GE.1.D0 ) THEN
25964 WRITE(LO,'(/1X,A,2E12.4)')
25965 & 'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25966 RETURN
25967 ENDIF
25968 SP = XA*XB*ECMH*ECMH
25969 UP =-ECMH*PT*EC*XB
25970 UP = UP/SP
25971 TP =-(1.D0+UP)
25972 UU = UP*UP
25973 TT = TP*TP
25974C set hard scale QQ for alpha and partondistr.
25975 IF ( NQQAL.EQ.1 ) THEN
25976 QQAL = AQQAL*PT*PT
25977 ELSEIF ( NQQAL.EQ.2 ) THEN
25978 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25979 ELSEIF ( NQQAL.EQ.3 ) THEN
25980 QQAL = AQQAL*SP
25981 ELSEIF ( NQQAL.EQ.4 ) THEN
25982 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25983 ENDIF
25984 IF ( NQQPD.EQ.1 ) THEN
25985 QQPD = AQQPD*PT*PT
25986 ELSEIF ( NQQPD.EQ.2 ) THEN
25987 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25988 ELSEIF ( NQQPD.EQ.3 ) THEN
25989 QQPD = AQQPD*SP
25990 ELSEIF ( NQQPD.EQ.4 ) THEN
25991 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25992 ENDIF
25993
25994 ALPHA1 = PHO_ALPHAS(QQAL,1)
25995 IF(IDPDG2.EQ.22) THEN
25996 ALPHA2 = pho_alphae(QQAL)
25997 ELSE IF(IDPDG2.EQ.990) THEN
25998 ALPHA2 = PARMDL(74)
25999 ENDIF
26000 FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
26001C parton distribution (times x)
26002 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
26003 S1 = PDA(0)
26004C charge counting
26005 S2 = 0.D0
26006 S3 = 0.D0
26007 IF(IDPDG2.EQ.22) THEN
26008 DO 70 I=1,NF
26009* IF(MOD(I,2).EQ.0) THEN
26010* S2 = S2 + (PDA(I)+PDA(-I))*TWO32
26011* S3 = S3 + TWO32
26012* ELSE
26013* S2 = S2 + (PDA(I)+PDA(-I))*ONE32
26014* S3 = S3 + ONE32
26015* ENDIF
26016 S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
26017 S3 = S3 + Q_ch2(I)
26018 70 CONTINUE
26019 ELSE IF(IDPDG2.EQ.990) THEN
26020 DO 75 I=1,NF
26021 S2 = S2 + PDA(I)+PDA(-I)
26022 75 CONTINUE
26023 S3 = NF
26024 ENDIF
26025C partial cross sections (including color and symmetry factors)
26026C direct photon matrix elements
26027 DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
26028 DSIGM(13) = (UU+TT)/(UP*TP)
26029C
26030 DSIGM(12) = FACTOR*DSIGM(12)*S2
26031 DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
26032C complex part
26033 X=ABS(TP-UP)
26034 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
26035C
26036 DO 80 I=12,13
26037 IF(DSIGM(I).LT.0.D0) THEN
26038 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
26039 & 'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
26040 DSIGM(I) = 0.D0
26041 ENDIF
26042 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
26043 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
26044 80 CONTINUE
26045 ENDIF
26046 END
26047
26048*$ CREATE PHO_HARXPT.FOR
26049*COPY PHO_HARXPT
26050CDECK ID>, PHO_HARXPT
26051 SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
26052C**********************************************************************
26053C
26054C differential cross section DSIG/DPT
26055C
26056C input: ECMH CMS energy of scattering system
26057C PT parton PT
26058C IPRO 1 resolved processes
26059C 2 direct processes
26060C 3 resolved and direct processes
26061C
26062C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
26063C
26064C**********************************************************************
26065 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26066 SAVE
26067
26068 PARAMETER ( Max_pro_2 = 16 )
26069 COMPLEX*16 DSIGMC
26070 DIMENSION DSIGMC(0:Max_pro_2)
26071 PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
26072
26073C input/output channels
26074 INTEGER LI,LO
26075 COMMON /POINOU/ LI,LO
26076C some constants
26077 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26078 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26079 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26080C model switches and parameters
26081 CHARACTER*8 MDLNA
26082 INTEGER ISWMDL,IPAMDL
26083 DOUBLE PRECISION PARMDL
26084 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26085C data of c.m. system of Pomeron / Reggeon exchange
26086 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26087 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26088 & SIDP,CODP,SIFP,COFP
26089 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26090 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26091 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26092C Reggeon phenomenology parameters
26093 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26094 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26095 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26096 & ALREG,ALREGP,GR(2),B0REG(2),
26097 & GPPP,GPPR,B0PPP,B0PPR,
26098 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26099C integration precision for hard cross sections (obsolete)
26100 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26101 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26102C hard scattering parameters used for most recent hard interaction
26103 INTEGER NFbeta,NF
26104 DOUBLE PRECISION ALQCD2,BQCD
26105 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26106C some hadron information, will be deleted in future versions
26107 INTEGER NFS
26108 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26109 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26110
26111 double precision pho_alphae
26112
26113 COMPLEX*16 DSIG1
26114 DIMENSION DSIG1(0:Max_pro_2)
26115 DIMENSION ABSZ(32),WEIG(32)
26116
26117 DO 10 M=0,Max_pro_2
26118 DSIGMC(M) = CMPLX(0.D0,0.D0)
26119 DSIG1(M) = CMPLX(0.D0,0.D0)
26120 10 CONTINUE
26121
26122C resolved and direct processes
26123 AMT = 2.D0*PT/ECMH
26124 IF ( AMT.GE.1.D0 ) RETURN
26125 ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
26126 ECL = -ECU
26127 NPOINT = NGAUET
26128 CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
26129 DO 30 I=1,NPOINT
26130 DSIG1(9) = CMPLX(0.D0,0.D0)
26131 DSIG1(15) = CMPLX(0.D0,0.D0)
26132 IF(IPRO.EQ.1) THEN
26133 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
26134 ELSE IF(IPRO.EQ.2) THEN
26135 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
26136 ELSE
26137 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
26138 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
26139 ENDIF
26140 DO 20 M=1,Max_pro_2
26141 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
26142 20 CONTINUE
26143 30 CONTINUE
26144
26145C direct processes
26146 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26147 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26148 FAC = 0.D0
26149 SS = ECMH*ECMH
26150 ALPHAE = pho_alphae(SS)
26151 DO 300 I=1,NF
26152 IF(IDPDG1.EQ.22) THEN
26153* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26154 F1 = Q_ch2(I)*ALPHAE
26155 ELSE
26156 F1 = PARMDL(74)
26157 ENDIF
26158 IF(IDPDG2.EQ.22) THEN
26159* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26160 F2 = Q_ch2(I)*ALPHAE
26161 ELSE
26162 F2 = PARMDL(74)
26163 ENDIF
26164 FAC = FAC+F1*F2*3.D0
26165 300 CONTINUE
26166C direct cross sections
26167 ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
26168 T1 = -SS/2.D0*(1.D0+ZZ)
26169 T2 = -SS/2.D0*(1.D0-ZZ)
26170 XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
26171C hadronic part
26172 DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
26173
26174C leptonic part (e, mu, tau)
26175 DSIGMC(16) = 0.D0
26176 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26177 DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
26178C simulation of tau together with quarks
26179 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26180 ENDIF
26181 ENDIF
26182
26183 DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
26184 DSIGMC(0) = DSIGMC(9)+DSIGMC(15)
26185
26186 END
26187
26188*$ CREATE PHO_HARXTO.FOR
26189*COPY PHO_HARXTO
26190CDECK ID>, PHO_HARXTO
26191 SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
26192C**********************************************************************
26193C
26194C total hard cross section (perturbative QCD, Parton Model)
26195C
26196C input: ECMH CMS energy of scattering system
26197C PTCUTR PT cutoff for resolved processes
26198C PTCUTD PT cutoff for direct processes (photon, Pomeron)
26199C
26200C output: DSIGMC(0:MARPR2) cross sections for given cutoff
26201C DSDPTC(0:MARPR2) differential cross sections at cutoff
26202C
26203C note: COMPLEX*16 DSIGMC
26204C DOUBLE PRECISION DSDPTC
26205C
26206C**********************************************************************
26207 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26208 SAVE
26209
26210 PARAMETER ( Max_pro_2 = 16 )
26211 COMPLEX*16 DSIGMC
26212 DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
26213
26214C input/output channels
26215 INTEGER LI,LO
26216 COMMON /POINOU/ LI,LO
26217C model switches and parameters
26218 CHARACTER*8 MDLNA
26219 INTEGER ISWMDL,IPAMDL
26220 DOUBLE PRECISION PARMDL
26221 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26222C data of c.m. system of Pomeron / Reggeon exchange
26223 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26224 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26225 & SIDP,CODP,SIFP,COFP
26226 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26227 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26228 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26229C Reggeon phenomenology parameters
26230 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26231 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26232 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26233 & ALREG,ALREGP,GR(2),B0REG(2),
26234 & GPPP,GPPR,B0PPP,B0PPR,
26235 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26236C some constants
26237 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26238 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26239 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26240C integration precision for hard cross sections (obsolete)
26241 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26242 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26243C some hadron information, will be deleted in future versions
26244 INTEGER NFS
26245 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26246 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26247C hard scattering parameters used for most recent hard interaction
26248 INTEGER NFbeta,NF
26249 DOUBLE PRECISION ALQCD2,BQCD
26250 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26251
26252 double precision pho_alphae
26253
26254 COMPLEX*16 DSIG1
26255 DIMENSION DSIG1(0:Max_pro_2)
26256 DIMENSION ABSZ(32),WEIG(32)
26257
26258 DATA FAC / 3.0D0 /
26259
26260 DO 10 M=0,Max_pro_2
26261 DSIGMC(M)= CMPLX(0.D0,0.D0)
26262 10 CONTINUE
26263 EEC=ECMH/2.001D0
26264C
26265 IF ( PTCUTR.GE.EEC ) GOTO 100
26266C
26267C integration for resolved processes
26268 PTMIN = PTCUTR
26269 PTMAX = MIN(FAC*PTMIN,EEC)
26270 NPOINT = NGAUP1
26271 CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26272 DO 60 M=1,9
26273 DSDPTC(M) = DREAL(DSIG1(M))
26274 60 CONTINUE
26275 DSIGH = DREAL(DSIG1(9))
26276 PTMXX = 0.95D0*PTMAX
26277 CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26278 DSIGL = DREAL(DSIG1(9))
26279 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26280 EX1 = 1.0D0-EX
26281 DO 50 K=1,2
26282 IF ( PTMIN.GE.PTMAX ) GOTO 40
26283 RL = PTMIN**EX1
26284 RU = PTMAX**EX1
26285 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26286 DO 30 I=1,NPOINT
26287 R = ABSZ(I)
26288 PT = R**(1.0D0/EX1)
26289 CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26290 F = WEIG(I)*PT/(R*EX1)
26291 DO 20 M=1,9
26292 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26293 20 CONTINUE
26294 30 CONTINUE
26295 40 PTMIN = PTMAX
26296 PTMAX = EEC
26297 NPOINT = NGAUP2
26298 50 CONTINUE
26299 100 CONTINUE
26300 DSIGMC(0) = DSIGMC(9)
26301 DSDPTC(0) = DSDPTC(9)
26302C
26303C integration for direct processes
26304 IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26305C
26306 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26307 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26308 PTMIN = PTCUTD
26309 PTMAX = MIN(FAC*PTMIN,EEC)
26310 NPOINT = NGAUP1
26311 CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26312 IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26313 DO 160 M=10,16
26314 DSDPTC(M) = DREAL(DSIG1(M))
26315 160 CONTINUE
26316 DSIGH = DREAL(DSIG1(15)-DSIG1(14))
26317 PTMXX = 0.95D0*PTMAX
26318 CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26319 DSIGL = DREAL(DSIG1(15)-DSIG1(14))
26320 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26321 EX1 = 1.0D0-EX
26322 DO 150 K=1,2
26323 IF ( PTMIN.GE.PTMAX ) GOTO 140
26324 RL = PTMIN**EX1
26325 RU = PTMAX**EX1
26326 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26327 DO 130 I=1,NPOINT
26328 R = ABSZ(I)
26329 PT = R**(1.0D0/EX1)
26330 CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26331 F = WEIG(I)*PT/(R*EX1)
26332 DO 120 M=10,15
26333 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26334 120 CONTINUE
26335 130 CONTINUE
26336 140 PTMIN = PTMAX
26337 PTMAX = EEC
26338 NPOINT = NGAUP2
26339 150 CONTINUE
26340 ENDIF
26341C
26342 170 CONTINUE
26343C
26344C double direct process
26345 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26346 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26347 FACC = 0.D0
26348 SS = ECMH*ECMH
26349 ALPHAE = pho_alphae(SS)
26350 DO 300 I=1,NF
26351 IF(IDPDG1.EQ.22) THEN
26352* F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26353 F1 = Q_ch2(I)*ALPHAE
26354 ELSE
26355 F1 = PARMDL(74)
26356 ENDIF
26357 IF(IDPDG2.EQ.22) THEN
26358* F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26359 F2 = Q_ch2(I)*ALPHAE
26360 ELSE
26361 F2 = PARMDL(74)
26362 ENDIF
26363 FACC = FACC + F1*F2*3.D0
26364 300 CONTINUE
26365
26366 ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26367 R = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26368C hadronic cross section
26369 DSIGMC(14) = R*FACC*AKFAC
26370C leptonic cross section
26371 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26372 DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26373C simulation of tau together with quarks
26374 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26375 DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26376 ELSE
26377 DSIGMC(16) = CMPLX(0.D0,0.D0)
26378 ENDIF
26379C sum of direct part
26380 DSIGMC(15) = CMPLX(0.D0,0.D0)
26381 DO 400 I=10,14
26382 DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26383 400 CONTINUE
26384 ENDIF
26385C total sum (hadronic)
26386 DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26387 DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26388
26389 END
26390
26391*$ CREATE PHO_HARISR.FOR
26392*COPY PHO_HARISR
26393CDECK ID>, PHO_HARISR
26394 SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26395 & XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26396C********************************************************************
26397C
26398C initial state radiation according to DGLAP evolution equations
26399C (backward evolution, no spin effects)
26400C
26401C input: IHPOM index of hard Pomeron
26402C negative: delete all previous entries
26403C P1,P2 4 momenta of hard scattered final partons
26404C (in CMS of hard scattering)
26405C IPF1,2 flavours of final partons
26406C IPA1,2 flavours of initial partons
26407C IV1,2 valence quark labels (0/1)
26408C Q2H momentum transfer (squared, positive)
26409C XH1,XH2 x values of initial partons
26410C XHMAX1,2 max. x values allowed
26411C
26412C output: all emitted partons in /POPISR/, final state
26413C partons are the first two entries
26414C shower evolution traced in /PODGL1/
26415C IPB1,2 flavours of new initial partons
26416C XISR1,2 x values of new initial partons
26417C IVO1,2 valence quark labels (0/1)
26418C
26419C attention: quark numbering according to PDG convention,
26420C but 0 for gluons
26421C
26422C********************************************************************
26423 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26424 SAVE
26425
26426 PARAMETER (RHOMAS = 0.766D0,
26427 & DEPS = 1.D-10,
26428 & TINY = 1.D-10)
26429
26430 DIMENSION P1(4),P2(4)
26431
26432C input/output channels
26433 INTEGER LI,LO
26434 COMMON /POINOU/ LI,LO
26435C event debugging information
26436 INTEGER NMAXD
26437 PARAMETER (NMAXD=100)
26438 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26439 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26440 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26441 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26442C internal rejection counters
26443 INTEGER NMXJ
26444 PARAMETER (NMXJ=60)
26445 CHARACTER*10 REJTIT
26446 INTEGER IFAIL
26447 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26448C model switches and parameters
26449 CHARACTER*8 MDLNA
26450 INTEGER ISWMDL,IPAMDL
26451 DOUBLE PRECISION PARMDL
26452 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26453C data of c.m. system of Pomeron / Reggeon exchange
26454 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26455 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26456 & SIDP,CODP,SIFP,COFP
26457 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26458 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26459 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26460C some hadron information, will be deleted in future versions
26461 INTEGER NFS
26462 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26463 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26464C currently activated parton density parametrizations
26465 CHARACTER*8 PDFNAM
26466 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26467 DOUBLE PRECISION PDFLAM,PDFQ2M
26468 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26469 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26470C scale parameters for parton model calculations
26471 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26472 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26473 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26474 & NQQAL,NQQALI,NQQALF,NQQPD
26475C parameters for DGLAP backward evolution in ISR
26476 INTEGER NFSISR
26477 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26478 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26479C initial state parton radiation (internal part)
26480 INTEGER MXISR3,MXISR4
26481 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26482 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26483 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26484 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26485 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26486 & IFL1(2,MXISR3),IFL2(2,MXISR3),
26487 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26488C some constants
26489 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26490 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26491 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26492C particles created by initial state evolution
26493 INTEGER MXISR1,MXISR2
26494 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26495 INTEGER IFLISR,IPOISR,IMXISR
26496 DOUBLE PRECISION PHISR
26497 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26498 & IPOISR(2,2,MXISR2),IMXISR(2)
26499
26500 DOUBLE PRECISION PYP,EER,THER,QMAXR
26501 INTEGER PYK
26502
26503 DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26504 & WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26505 & IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26506
26507 IREJ = 0
26508 NTRY = 1000
26509 NITER = 0
26510C debug output
26511 IF(IDEB(79).GE.10) THEN
26512 WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26513 & 'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26514 & KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26515 ENDIF
26516 IF(IHPOM.EQ.0) RETURN
26517C
26518 10 CONTINUE
26519 NACC = 0
26520 IDMO(1) = IDPDG1
26521 IDMO(2) = IDPDG2
26522C
26523C copy final state partons to local fields
26524 IHIDX = ABS(IHPOM)
26525
26526 IF(IHIDX.GT.MXISR2) THEN
26527 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26528 & '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26529 & IHIDX,MXISR2
26530 IREJ = 1
26531 ENDIF
26532
26533 DO 50 K=1,2
26534 IF(IHPOM.LT.0) IMXISR(K) = 0
26535 IPOISR(K,1,IHIDX) = IMXISR(K)+1
26536 IPAL(K) = IPOISR(K,1,IHIDX)
26537 50 CONTINUE
26538 DO 55 I=1,4
26539 PHISR(1,I,IPAL(1)) = P1(I)
26540 PHISR(2,I,IPAL(2)) = P2(I)
26541 55 CONTINUE
26542 IFLISR(1,IPAL(1)) = IPF1
26543 IFLISR(2,IPAL(2)) = IPF2
26544C
26545C check limitations, initialize /PODGL1/
26546 IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26547 NEXT(1) = 1
26548 Q2SH(1,1) = Q2H
26549 ELSE
26550 NEXT(1) = 0
26551 Q2SH(1,1) = 0.D0
26552 ENDIF
26553 IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26554 NEXT(2) = 1
26555 Q2SH(2,1) = Q2H
26556 ELSE
26557 NEXT(2) = 0
26558 Q2SH(2,1) = 0.D0
26559 ENDIF
26560C
26561 ISH(1) = 1
26562 ISH(2) = 1
26563 XPSH(1,1) = XH1
26564 XPSH(2,1) = XH2
26565C
26566 IFL1(1,1) = IPA1
26567 IVAL(1) = IV1
26568 IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26569 IFL1(2,1) = IPA2
26570 IVAL(2) = IV2
26571 IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26572C
26573 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26574 & 'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26575 IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26576C
26577C initialize parton shower loop
26578 B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26579 AL2ISR(1) = PDFLAM(1)
26580 AL2ISR(2) = PDFLAM(2)
26581 XHMA(1) = XHMAX1
26582 XHMA(2) = XHMAX2
26583 XHMI(1) = PMISR(1)/PCMP
26584 XHMI(2) = PMISR(2)/PCMP
26585 ZPSH(1,1) = 1.D0
26586 ZPSH(2,1) = 1.D0
26587 SHAT1 = XH1*XH2*ECMP**2
26588 IF(IPAMDL(109).EQ.1) THEN
26589 PT2SH(1,1) = Q2H
26590 ELSE
26591 PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26592 ENDIF
26593 PT2SH(2,1) = PT2SH(1,1)
26594 IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26595 IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26596 THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26597 THSH(2,1) = THSH(1,1)
26598 IFANO(1) = 0
26599 IFANO(2) = 0
26600 ZZ = 1.D0
26601 IF(IREJ.NE.0) GOTO 800
26602C
26603C main generation loop
26604C -------------------------------------------------
26605 100 CONTINUE
26606C choose parton side to become solved
26607 IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26608 IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26609 IP = 1
26610 ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26611 IP = 2
26612 ELSE
26613 IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26614 ENDIF
26615 ELSE IF(NEXT(1).EQ.1) THEN
26616 IP = 1
26617 ELSE IF(NEXT(2).EQ.1) THEN
26618 IP = 2
26619 ELSE
26620 GOTO 800
26621 ENDIF
26622 INDX = ISH(IP)
26623C INDX now parton position of parton to become solved
26624C IP now side to be treated
26625 XP = XPSH(IP,INDX)
26626 Q2P = Q2SH(IP,INDX)
26627 PT2 = PT2SH(IP,INDX)
26628 IFLB = IFL1(IP,INDX)
26629C check available x
26630 XMIP = XHMI(IP)
26631C cutoff by x limitation: no further development
26632 IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26633 NEXT(IP) = 0
26634 Q2SH(IP,INDX) = 0.D0
26635 IF(IDEB(79).GE.17) THEN
26636 WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26637 & 'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26638 & XP,XMIP,XHMA(IP),IP,INDX
26639 ENDIF
26640 GOTO 100
26641 ENDIF
26642C initial value of evolution variable t
26643 TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26644 DO 110 I=-NFSISR,NFSISR
26645 WGGAP(I) = 0.D0
26646 WGPDF(I) = 0.D0
26647 110 CONTINUE
26648C DGLAP weights
26649 ZMIN = XP/XHMA(IP)
26650 ZMAX = XP/(XP+XMIP)
26651 CF = 4./3.
26652C q --> q g, g --> g g
26653 IF(IFLB.EQ.0) THEN
26654 WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26655 & +2.D0*LOG(ZMAX/ZMIN))
26656 DO 120 I=1,NFSISR
26657 WGGAP(I) = WGGAP(0)
26658 WGGAP(-I) = WGGAP(0)
26659 120 CONTINUE
26660 WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26661 & -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26662C q --> g q, g --> q qb
26663 ELSE IF(ABS(IFLB).LE.6) THEN
26664 WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26665 & -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26666 IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26667 & -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26668 ELSE
26669 WRITE(LO,'(/1X,A,I7)')
26670 & 'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26671 CALL PHO_ABORT
26672 ENDIF
26673C anomalous/resolved evolution
26674 IPDFC = 0
26675 IF(IPAMDL(110).GE.1) THEN
26676 IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26677 & .AND.(IFLB.NE.21)) THEN
26678 WGDIR = 0.D0
26679 IF(NQQALI.EQ.1) THEN
26680 SCALE2 = PT2*AQQPD
26681 ELSE
26682 SCALE2 = Q2P*AQQPD
26683 ENDIF
26684 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26685 IPDFC = 1
26686 CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26687 XI = DT_RNDM(XP)*PD1(IFLB)
26688 IF(WGDIR.GT.XI) THEN
26689C debug output
26690 IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26691 & 'PHO_HARISR: ',
26692 & 'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26693 & WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26694 Q2SH(IP,INDX) = 0.D0
26695 NEXT(IP) = 0
26696 IFANO(IP) = INDX
26697 GOTO 100
26698 ENDIF
26699 ENDIF
26700 ENDIF
26701C
26702C rejection loop for z,t sampling
26703C ------------------------------------
26704 200 CONTINUE
26705 NITER = NITER+1
26706 IF(NITER.GE.NTRY) THEN
26707 WRITE(LO,'(1X,A,2I6)')
26708 & 'PHO_HARISR: too many rejections',NITER,NTRY
26709 CALL PHO_PREVNT(-1)
26710C clean up event
26711 IREJ = 1
26712 GOTO 10
26713 ENDIF
26714C PDF weights
26715 IF(IPDFC.EQ.0) THEN
26716 IF(NQQALI.EQ.1) THEN
26717 SCALE2 = PT2*AQQPD
26718 ELSE
26719 SCALE2 = Q2P*AQQPD
26720 ENDIF
26721 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26722 ENDIF
26723 IPDFC = 0
26724C
26725 WGTOT = 0.D0
26726 DO 210 I=-NFSISR,NFSISR
26727 WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26728 WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26729 210 CONTINUE
26730C
26731 215 CONTINUE
26732C sample new t value
26733 TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26734 Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26735C debug output
26736 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26737 & 'PHO_HARISR: pre-selected Q2:',Q2NEW
26738C compare to limits
26739 IF(Q2NEW.LT.Q2MISR(IP)) THEN
26740 Q2SH(IP,INDX) = 0.D0
26741 NEXT(IP) = 0
26742 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26743 & 'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26744 & Q2NEW,Q2MISR(IP),IP,INDX
26745 GOTO 100
26746 ENDIF
26747 Q2SH(IP,INDX) = Q2NEW
26748 TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26749C selection of flavours
26750 XI = WGTOT*DT_RNDM(TT)
26751 IFLA = -NFSISR-1
26752 220 CONTINUE
26753 IFLA = IFLA+1
26754 XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26755 IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26756C debug output
26757 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26758 & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26759C selection of z
26760 CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26761C debug output
26762 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26763 & 'PHO_HARISR: pre-selected ZZ',ZZ
26764C angular ordering
26765 THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26766 IF(THETA.GT.THSH(IP,INDX)) THEN
26767 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26768 & 'PHO_HARISR: reject by angle (NEW/OLD)',
26769 & THETA,THSH(IP,INDX)
26770 GOTO 215
26771 ENDIF
26772C rejection weight given by new PDFs
26773 XNEW = XP/ZZ
26774 PT2NEW = Q2NEW*(1.D0-ZZ)
26775 IF(NQQALI.EQ.1) THEN
26776 SCALE2 = PT2NEW*AQQPD
26777 ELSE
26778 SCALE2 = Q2NEW*AQQPD
26779 ENDIF
26780 IF(SCALE2.LT.Q2MISR(IP)) THEN
26781 Q2SH(IP,INDX) = 0.D0
26782 NEXT(IP) = 0
26783 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26784 & 'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26785 & Q2NEW,Q2MISR(IP),IP,INDX
26786 GOTO 100
26787 ENDIF
26788 CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26789 IF(PD2(IFLA).LT.1.D-10) GOTO 200
26790 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26791 PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26792 WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26793 IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26794 & /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26795 IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26796 WRITE(LO,'(1X,A,E12.3)')
26797 & 'PHO_HARISR: final weight:',WGF
26798 WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26799 & 'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26800 ENDIF
26801 IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26802
26803 IF(IDEB(79).GE.15) THEN
26804 WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26805 & 'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26806 & IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26807 ENDIF
26808
26809 IF(INDX.GE.MXISR3) THEN
26810 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26811 & '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26812 IREJ = 1
26813 RETURN
26814 ENDIF
26815
26816C branching accepted, registration
26817 Q2SH(IP,INDX) = Q2NEW
26818 PT2SH(IP,INDX) = PT2NEW
26819 ZPSH(IP,INDX) = ZZ
26820 IFL2(IP,INDX) = IFLA-IFLB
26821 Q2SH(IP,INDX+1) = Q2NEW
26822 PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26823 XPSH(IP,INDX+1) = XNEW
26824 THSH(IP,INDX+1) = THETA
26825 IFL1(IP,INDX+1) = IFLA
26826 ISH(IP) = ISH(IP)+1
26827
26828 NACC = NACC+1
26829
26830 IF(NACC.GT.MXISR4) THEN
26831 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26832 & '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26833 IREJ = 1
26834 RETURN
26835 ENDIF
26836
26837 SHAT(NACC) = SHAT1
26838 IBRA(1,NACC) = IP
26839 IBRA(2,NACC) = INDX
26840 SHAT1 = SHAT1/ZZ
26841
26842C generation of next branching
26843 IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26844
26845 800 CONTINUE
26846
26847C new initial flavours, x values
26848 IPB1 = IFL1(1,ISH(1))
26849 IPB2 = IFL1(2,ISH(2))
26850 XISR1 = XPSH(1,ISH(1))
26851 XISR2 = XPSH(2,ISH(2))
26852 IVO1 = IVAL(1)
26853 IVO2 = IVAL(2)
26854C valence flavours
26855 IF(IPB1.NE.0) THEN
26856 IF(ISH(1).GT.1) THEN
26857 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26858 IF(IDPDG1.EQ.22) THEN
26859 CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26860 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26861 ELSE
26862 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26863 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26864 ENDIF
26865 ENDIF
26866 ENDIF
26867 IF(IPB2.NE.0) THEN
26868 IF(ISH(2).GT.1) THEN
26869 CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26870 IF(IDPDG2.EQ.22) THEN
26871 CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26872 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26873 ELSE
26874 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26875 ENDIF
26876 ENDIF
26877 ENDIF
26878
26879C parton kinematics
26880 IF(NACC.GT.0) THEN
26881C final partons in CMS
26882 PM(3) = (XH1-XH2)*ECMP/2.D0
26883 PM(4) = (XH1+XH2)*ECMP/2.D0
26884 SH = XH1*XH2*ECMP**2
26885 SSH = SQRT(SH)
26886 GB(3) = PM(3)/SSH
26887 GB(4) = PM(4)/SSH
26888 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26889 & P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26890 & PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26891 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26892 & P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26893 & PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26894 IL(1) = 1
26895 IL(2) = 1
26896 DO 900 I=1,NACC
26897 IPA = IBRA(1,I)
26898 IPB = 3-IPA
26899 IL(IPA) = IBRA(2,I)
26900C new initial partons in CMS
26901 SH = SHAT(I)
26902 SSH = SQRT(SH)
26903 SHZ = SH/ZPSH(IPA,IL(IPA))
26904 SSHZ = SQRT(SHZ)
26905 Q2(1) = Q2SH(1,IL(1))
26906 Q2(2) = Q2SH(2,IL(2))
26907 PC(1,1) = 0.D0
26908 PC(1,2) = 0.D0
26909 PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26910 & /(2.D0*SSH)
26911 PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26912 PC(2,1) = 0.D0
26913 PC(2,2) = 0.D0
26914 PC(2,3) = -PC(1,3)
26915 PC(2,4) = SSH-PC(1,4)
26916 XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26917 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26918 S1 = SH+Q2(IPA)+Q2(IPB)
26919 S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26920 R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26921 R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26922 IF(Q2(IPB).LT.0.1D0) THEN
26923 XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26924 & *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26925 ELSE
26926 XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26927 & -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26928 ENDIF
26929 NGEN = 1
26930C max. virtuality for time-like showers
26931 QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26932 IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26933C generate time-like parton shower
26934 KF = IFL2(IPA,IL(IPA))
26935 IF(KF.EQ.0) KF = 21
26936 EER = MIN(EE3-PC(IPA,4),ECMP)
26937 THER = 0.
26938
26939 CALL PY1ENT(1,KF,EER,THER,THER)
26940 QMAXR = SQRT(QMAX)
26941 CALL PYSHOW(1,0,QMAXR)
26942C debug output
26943 IF(IDEB(79).GE.25) THEN
26944 WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26945 & 'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26946 & EER,QMAX,XMS4M,Q2(IPA)
26947 CALL PYLIST(1)
26948 ENDIF
26949 NGEN = PYK(0,1)
26950
26951 IF(NGEN.GT.1) THEN
26952 PJX = 0.D0
26953 PJY = 0.D0
26954 PJZ = 0.D0
26955 PJE = 0.D0
26956 KK = IPAL(IPA)
26957 DO 820 K=3,NGEN
26958
26959 IF(PYK(K,1).LE.4) THEN
26960 KK = KK+1
26961
26962 IF(KK.GT.MXISR1) THEN
26963 WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26964 & 'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26965 IREJ = 1
26966 RETURN
26967 ENDIF
26968
26969 PHISR(IPA,1,KK) = PYP(K,1)
26970 PJX = PJX+PHISR(IPA,1,KK)
26971 PHISR(IPA,2,KK) = PYP(K,2)
26972 PJY = PJY+PHISR(IPA,2,KK)
26973 PHISR(IPA,3,KK) = PYP(K,3)
26974 PJZ = PJZ+PHISR(IPA,3,KK)
26975 PHISR(IPA,4,KK) = PYP(K,4)
26976 PJE = PJE+PHISR(IPA,4,KK)
26977 IFLISR(IPA,KK) = PYK(K,2)
26978
26979 IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26980 IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26981 IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26982 ENDIF
26983 820 CONTINUE
26984 NGEN = KK-IPAL(IPA)
26985 XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26986 PP4 = SQRT(PJE**2-XMS4)
26987 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26988C debug output
26989 IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26990 & 'PHO_HARISR: ',
26991 & 'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26992 & PJE,PJX,PJY,PJZ,PP4,XMS4
26993 ENDIF
26994 ENDIF
26995 PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26996 & /(2.D0*PC(IPA,3))
26997 PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26998 IF(PT3.LT.0.D0) THEN
26999 IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
27000 & 'PHO_HARISR: rejection due to PT3',PT3
27001 GOTO 10
27002 ENDIF
27003 PT3 = SQRT(PT3)
27004 CALL PHO_SFECFE(SFE,CFE)
27005 PX3 = CFE*PT3
27006 PY3 = SFE*PT3
27007C
27008 IF(NGEN.GT.1) THEN
27009C time-like shower generated
27010 EE4 = EE3-PC(IPA,4)
27011 PZ4 = PZ3-PC(IPA,3)
27012 PP4 = SQRT(PT3**2+PZ4**2)
27013C Lorentz boost
27014 GAM = (EE4*PJE-PP4*PJZ)/XMS4
27015 BEG = (PJE*PP4-EE4*PJZ)/XMS4
27016C rotation angles
27017 CODD = PZ4/PP4
27018 SIDD = SQRT(PX3**2+PY3**2)/PP4
27019 COFD = 1.D0
27020 SIFD = 0.D0
27021 IF(PP4*SIDD.GT.1.D-5) THEN
27022 COFD = PX3/(SIDD*PP4)
27023 SIFD = PY3/(SIDD*PP4)
27024 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
27025 COFD = COFD/ANORF
27026 SIFD = SIFD/ANORF
27027 ENDIF
27028C copy partons back
27029 KK = IPAL(IPA)
27030 DO 830 K=1,NGEN
27031 KK = KK+1
27032 PX = PHISR(IPA,1,KK)
27033 PY = PHISR(IPA,2,KK)
27034 PZ = PHISR(IPA,3,KK)
27035 COH= PHISR(IPA,4,KK)
27036 EE = GAM*COH+BEG*PZ
27037 PZ = GAM*PZ +BEG*COH
27038 PHISR(IPA,4,KK) = EE
27039 CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
27040 & PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
27041 830 CONTINUE
27042 IPAL(IPA) = KK
27043 ELSE
27044C no time-like shower generated
27045 IPAL(IPA) = IPAL(IPA)+1
27046 PHISR(IPA,1,IPAL(IPA)) = PX3
27047 PHISR(IPA,2,IPAL(IPA)) = PY3
27048 PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
27049 PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
27050 IFLISR(IPA,IPAL(IPA)) = IFL2(IPA,IL(IPA))
27051 ENDIF
27052 PC(IPA,1) = PX3
27053 PC(IPA,2) = PY3
27054 PC(IPA,3) = PZ3
27055 PC(IPA,4) = EE3
27056C boost / rotate into new CMS
27057 DO 842 K=1,4
27058 GB(K) = (PC(1,K)+PC(2,K))/SSHZ
27059 842 CONTINUE
27060 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
27061 & PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
27062 COG= PM(3)/PTOT1
27063 SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
27064 COH=1.D0
27065 SIH=0.D0
27066 IF(PTOT1*SIG.GT.1.D-5) THEN
27067 COH=PM(1)/(SIG*PTOT1)
27068 SIH=PM(2)/(SIG*PTOT1)
27069 ANORF=SQRT(COH*COH+SIH*SIH)
27070 COH=COH/ANORF
27071 SIH=SIH/ANORF
27072 ENDIF
27073 DO 845 K=1,2
27074 DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
27075 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
27076 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
27077 & PTOT1,PM(1),PM(2),PM(3),PM(4))
27078 CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
27079 & PN(2),PN(3))
27080 CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
27081 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
27082 PHISR(K,4,L) = PM(4)
27083 844 CONTINUE
27084 845 CONTINUE
27085 900 CONTINUE
27086C boost back to global CMS
27087 PM(3) = (XISR1-XISR2)/2.D0
27088 PM(4) = (XISR1+XISR2)/2.D0
27089 SSH = SQRT(XISR1*XISR2)
27090 GB(3) = PM(3)/SSH
27091 GB(4) = PM(4)/SSH
27092 DO 945 K=1,2
27093 DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
27094 CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
27095 & PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
27096 & PM(2),PM(3),PM(4))
27097 PHISR(K,1,L) = PM(1)
27098 PHISR(K,2,L) = PM(2)
27099 PHISR(K,3,L) = PM(3)
27100 PHISR(K,4,L) = PM(4)
27101 944 CONTINUE
27102 945 CONTINUE
27103 ENDIF
27104 IPOISR(1,2,IHIDX) = IPAL(1)
27105 IPOISR(2,2,IHIDX) = IPAL(2)
27106 IMXISR(1) = IPAL(1)
27107 IMXISR(2) = IPAL(2)
27108C
27109C debug output
27110 IF(IDEB(79).GE.10) THEN
27111 WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
27112 & ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
27113 IF(NACC.GT.0) THEN
27114 WRITE(LO,'(1X,A,2I5,/6X,A)')
27115 & 'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
27116 & ' SIDE NO. IFLB IFLC Q2SH PT2SH XH ZZ'
27117 DO 600 II=1,NACC
27118 K = IBRA(1,II)
27119 I = IBRA(2,II)
27120 WRITE(LO,'(5X,4I5,4E11.3)')
27121 & K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
27122 & ZPSH(K,I)
27123 600 CONTINUE
27124 ENDIF
27125C check of final configuration
27126 PX3 = 0.D0
27127 PY3 = 0.D0
27128 PZ3 = 0.D0
27129 EE3 = 0.D0
27130 IFSUM(1) = 0
27131 IFSUM(2) = 0
27132 WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
27133 DO 745 K=1,2
27134 DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
27135 WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
27136 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
27137 IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
27138 PX3 = PX3 + PHISR(K,1,L)
27139 PY3 = PY3 + PHISR(K,2,L)
27140 PZ3 = PZ3 + PHISR(K,3,L)
27141 EE3 = EE3 + PHISR(K,4,L)
27142 744 CONTINUE
27143 745 CONTINUE
27144 IFSUM(1) = IFSUM(1)-IPB1
27145 IFSUM(2) = IFSUM(2)-IPB2
27146 PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
27147 EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
27148 WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
27149 & IFSUM,PX3,PY3,PZ3,EE3
27150 ENDIF
27151 END
27152
27153*$ CREATE PHO_HARZSP.FOR
27154*COPY PHO_HARZSP
27155CDECK ID>, PHO_HARZSP
27156 SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
27157C*********************************************************************
27158C
27159C sampling of z values from DGLAP kernels
27160C
27161C input: IFLA,IFLB parton flavours
27162C NFSH flavours involved in hard processes
27163C ZMIN minimal ZZ allowed
27164C ZMAX maximal ZZ allowed
27165C
27166C output: ZZ z value
27167C
27168C*********************************************************************
27169 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27170 SAVE
27171
27172 PARAMETER ( DEPS = 1.D-10 )
27173
27174C input/output channels
27175 INTEGER LI,LO
27176 COMMON /POINOU/ LI,LO
27177C event debugging information
27178 INTEGER NMAXD
27179 PARAMETER (NMAXD=100)
27180 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27181 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27182 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27183 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27184C internal rejection counters
27185 INTEGER NMXJ
27186 PARAMETER (NMXJ=60)
27187 CHARACTER*10 REJTIT
27188 INTEGER IFAIL
27189 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27190
27191 IF(ZMAX.LE.ZMIN) THEN
27192 WRITE(LO,'(1X,A,2E12.3)')
27193 & 'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
27194 CALL PHO_PREVNT(-1)
27195 ZZ = 0.D0
27196 RETURN
27197 ENDIF
27198C
27199 IF(IFLB.EQ.0) THEN
27200 IF(IFLA.EQ.0) THEN
27201C g --> g g
27202 C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
27203 C2 = (1.D0-ZMIN)/ZMIN
27204 100 CONTINUE
27205 ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
27206 IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
27207 ELSE IF(ABS(IFLA).LE.NFSH) THEN
27208C q --> q g
27209 C1 = ZMAX/ZMIN
27210 200 CONTINUE
27211 ZZ = ZMIN*C1**DT_RNDM(ZMIN)
27212 IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
27213 ELSE
27214 GOTO 900
27215 ENDIF
27216 ELSE IF(ABS(IFLB).LE.NFSH) THEN
27217 IF(IFLA.EQ.0) THEN
27218C g --> q qb
27219 C1 = ZMAX-ZMIN
27220 300 CONTINUE
27221 ZZ = ZMIN+C1*DT_RNDM(ZMIN)
27222 IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
27223 ELSE IF(ABS(IFLA).LE.NFSH) THEN
27224C q --> g q
27225 C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
27226 C2 = 1.D0-ZMIN
27227 400 CONTINUE
27228 ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
27229 IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
27230 ELSE
27231 GOTO 900
27232 ENDIF
27233 ELSE
27234 GOTO 900
27235 ENDIF
27236C debug output
27237 IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
27238 & 'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
27239 & IFLA,IFLB,ZZ,ZMIN,ZMAX
27240 RETURN
27241
27242 900 CONTINUE
27243 WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
27244 & IFLA,IFLB
27245 CALL PHO_ABORT
27246
27247 END
27248
27249*$ CREATE PHO_ALPHAE.FOR
27250*COPY PHO_ALPHAE
27251CDECK ID>, PHO_ALPHAE
27252 DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
27253C**********************************************************************
27254C
27255C calculation of ALPHA_em
27256C
27257C input: Q2 scale in GeV**2
27258C
27259C**********************************************************************
27260
27261 IMPLICIT NONE
27262
27263 SAVE
27264
27265 DOUBLE PRECISION Q2
27266
27267C input/output channels
27268 INTEGER LI,LO
27269 COMMON /POINOU/ LI,LO
27270C model switches and parameters
27271 CHARACTER*8 MDLNA
27272 INTEGER ISWMDL,IPAMDL
27273 DOUBLE PRECISION PARMDL
27274 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27275
27276 DOUBLE PRECISION PYALEM
27277
27278 pho_alphae = 1.D0/137.D0
27279
27280 if(ipamdl(120).eq.1) then
27281
27282 pho_alphae = PYALEM(Q2)
27283
27284 endif
27285
27286 END
27287
27288*$ CREATE PHO_ALPHAS.FOR
27289*COPY PHO_ALPHAS
27290CDECK ID>, PHO_ALPHAS
27291 DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27292C**********************************************************************
27293C
27294C calculation of ALPHA_S
27295C
27296C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
27297C 2 lambda_QCD**2 for PDF 2 evolution
27298C 3 lambda_QCD**2 for hard scattering
27299C Q2 scale in GeV**2
27300C
27301C initialization needed:
27302C IMODE = 0 lambda values taken from PDF table
27303C -1 given Q2 is 4-flavour lambda 1
27304C -2 given Q2 is 4-flavour lambda 2
27305C -3 given Q2 is 4-flavour lambda 3
27306C
27307C
27308C**********************************************************************
27309
27310 IMPLICIT NONE
27311
27312 SAVE
27313
27314 DOUBLE PRECISION Q2
27315 INTEGER IMODE
27316
27317C input/output channels
27318 INTEGER LI,LO
27319 COMMON /POINOU/ LI,LO
27320C model switches and parameters
27321 CHARACTER*8 MDLNA
27322 INTEGER ISWMDL,IPAMDL
27323 DOUBLE PRECISION PARMDL
27324 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27325C hard scattering parameters used for most recent hard interaction
27326 INTEGER NFbeta,NF
27327 DOUBLE PRECISION ALQCD2,BQCD
27328 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27329C currently activated parton density parametrizations
27330 CHARACTER*8 PDFNAM
27331 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27332 DOUBLE PRECISION PDFLAM,PDFQ2M
27333 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27334 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27335
27336 INTEGER I
27337
27338 PHO_ALPHAS = 0.D0
27339
27340 IF(IMODE.GT.0) THEN
27341
27342 IF(Q2.LT.PARMDL(148)) THEN
27343 NFbeta = 1
27344 ELSE IF(Q2.LT.PARMDL(149)) THEN
27345 NFbeta = 2
27346 ELSE IF(Q2.LT.PARMDL(150)) THEN
27347 NFbeta = 3
27348 ELSE
27349 NFbeta = 4
27350 ENDIF
27351
27352 PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27353 NFbeta = NFbeta+2
27354
27355 ELSE IF(IMODE.EQ.0) THEN
27356
27357 DO I=1,3
27358 if(I.EQ.3) then
27359 ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27360 else
27361 ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27362 endif
27363 ALQCD2(I,1) = PARMDL(148)
27364 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27365 ALQCD2(I,3) = PARMDL(149)
27366 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27367 ALQCD2(I,4) = PARMDL(150)
27368 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27369
27370 ENDDO
27371
27372 ELSE IF(IMODE.LT.0) THEN
27373
27374 if(IMODE.eq.-4) then
27375 I = 3
27376 ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27377 else
27378 I = -IMODE
27379 ALQCD2(I,2) = Q2
27380 endif
27381 ALQCD2(I,1) = PARMDL(148)
27382 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27383 ALQCD2(I,3) = PARMDL(149)
27384 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27385 ALQCD2(I,4) = PARMDL(150)
27386 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27387
27388 ENDIF
27389
27390 END
27391
27392*$ CREATE PHO_DFWRAP.FOR
27393*COPY PHO_DFWRAP
27394CDECK ID>, PHO_DFWRAP
27395 SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27396C**********************************************************************
27397C
27398C wrapper for diffraction dissociation in hadron-nucleus and
27399C nucleus-nucleus collisions with DPMJET
27400C
27401C input: MODE 1: transformation into CMS
27402C 2: transformation into Lab
27403C JM1/2 indices of old mother particles
27404C JM1/2N indices of new mother particles
27405C
27406C**********************************************************************
27407
27408 IMPLICIT NONE
27409
27410 SAVE
27411
27412 INTEGER MODE,JM1,JM2
27413
27414C input/output channels
27415 INTEGER LI,LO
27416 COMMON /POINOU/ LI,LO
27417C event debugging information
27418 INTEGER NMAXD
27419 PARAMETER (NMAXD=100)
27420 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27421 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27422 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27423 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27424
27425C standard particle data interface
27426 INTEGER NMXHEP
27427
27428 PARAMETER (NMXHEP=4000)
27429
27430 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27431 DOUBLE PRECISION PHEP,VHEP
27432 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27433 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27434 & VHEP(4,NMXHEP)
27435C extension to standard particle data interface (PHOJET specific)
27436 INTEGER IMPART,IPHIST,ICOLOR
27437 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27438
27439C nucleon-nucleus / nucleus-nucleus interface to DPMJET
27440 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27441 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27442 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27443 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27444
27445 DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27446 DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27447
27448 INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27449
27450C transformation into CMS
27451
27452 IF(MODE.EQ.1) THEN
27453
27454 JM1S = JM1
27455 JM2S = JM2
27456 NHEPS = NHEP
27457
27458 XM1 = PHEP(5,JM1)
27459 XM2 = PHEP(5,JM2)
27460
27461C boost into CMS
27462 P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27463 P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27464 P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27465 P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27466 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27467 ECMD = SQRT(SS)
27468 DO 10 I=1,4
27469 GAMBED(I) = P1(I)/ECMD
27470 10 CONTINUE
27471 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27472 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27473 & PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27474C rotation angles
27475 CODD = P1(3)/PTOT1
27476 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27477 COFD = 1.D0
27478 SIFD = 0.D0
27479 IF(PTOT1*SIDD.GT.1.D-5) THEN
27480 COFD = P1(1)/(SIDD*PTOT1)
27481 SIFD = P1(2)/(SIDD*PTOT1)
27482 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27483 COFD = COFD/ANORF
27484 SIFD = SIFD/ANORF
27485 ENDIF
27486
27487C initial particles in CMS
27488
27489 P1(1) = 0.D0
27490 P1(2) = 0.D0
27491 P1(3) = ECMD/2.D0*XPSUB
27492 P1(4) = P1(3)
27493
27494 P2(1) = 0.D0
27495 P2(2) = 0.D0
27496 P2(3) = -ECMD/2.D0*XTSUB
27497 P2(4) = -P2(3)
27498
27499 CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27500
27501 CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27502 & P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27503 & ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27504
27505 CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27506 & P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27507 & ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27508
27509 JM1 = JM1N
27510 JM2 = JM2N
27511
27512C transformation into lab.
27513
27514 ELSE IF(MODE.EQ.2) THEN
27515
27516 CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27517 & GAMBED(1),GAMBED(2),GAMBED(3))
27518
27519 JM1 = JM1S
27520 JM2 = JM2S
27521
27522C clean up after rejection
27523
27524 ELSE IF(MODE.EQ.-2) THEN
27525
27526 NHEP = NHEPS
27527
27528 JM1 = JM1S
27529 JM2 = JM2S
27530
27531 ELSE
27532
27533 WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27534
27535 ENDIF
27536
27537 END
27538
27539*$ CREATE PHO_DIFDIS.FOR
27540*COPY PHO_DIFDIS
27541CDECK ID>, PHO_DIFDIS
27542 SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27543 & MSOFT,MHARD,IREJ)
27544C***********************************************************************
27545C
27546C sampling of diffractive events of different kinds,
27547C (produced particles stored in /POEVT1/)
27548C
27549C input: IDIF1/2 diffractive process particle 1/2
27550C 0 elastic/quasi-elastic scattering
27551C 1 diffraction dissociation
27552C IMOTH1/2 index of mother particles in /POEVT1/
27553C SPROB suppression factor (survival probability) for
27554C resolved diffraction dissociation
27555C IMODE mode of operation
27556C 0 sampling of diffractive cut
27557C 1 sampling of enhanced cut
27558C 2 sampling of diffractive cut without
27559C scattering (needed for double-pomeron)
27560C -1 initialization
27561C -2 output of statistics
27562C
27563C output: MSOFT number of generated soft strings
27564C MHARD number of generated hard strings
27565C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
27566C 0 quasi elastic scattering
27567C 1 low-mass diffractive dissociation
27568C 2 soft high-mass diffractive dissociation
27569C 3 hard resolved diffractive dissociation
27570C 4 hard direct diffractive dissociation
27571C IREJ rejection label
27572C 0 successful generation of partons
27573C 1 failure
27574C
27575C***********************************************************************
27576 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27577 SAVE
27578
27579 PARAMETER ( EPS = 1.D-7,
27580 & DEPS = 1.D-10)
27581
27582C input/output channels
27583 INTEGER LI,LO
27584 COMMON /POINOU/ LI,LO
27585C event debugging information
27586 INTEGER NMAXD
27587 PARAMETER (NMAXD=100)
27588 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27589 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27590 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27591 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27592C general process information
27593 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27594 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27595C internal rejection counters
27596 INTEGER NMXJ
27597 PARAMETER (NMXJ=60)
27598 CHARACTER*10 REJTIT
27599 INTEGER IFAIL
27600 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27601C global event kinematics and particle IDs
27602 INTEGER IFPAP,IFPAB
27603 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27604 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27605C c.m. kinematics of diffraction
27606 INTEGER NPOSD
27607 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27608 & SIDD,CODD,SIFD,COFD,PDCMS
27609 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27610 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27611C obsolete cut-off information
27612 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27613 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27614C some constants
27615 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27616 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27617 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27618C model switches and parameters
27619 CHARACTER*8 MDLNA
27620 INTEGER ISWMDL,IPAMDL
27621 DOUBLE PRECISION PARMDL
27622 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27623C Reggeon phenomenology parameters
27624 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27625 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27626 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27627 & ALREG,ALREGP,GR(2),B0REG(2),
27628 & GPPP,GPPR,B0PPP,B0PPR,
27629 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27630C parameters of 2x2 channel model
27631 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27632 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27633C table of particle indices for recursive PHOJET calls
27634 INTEGER MAXIPX
27635 PARAMETER ( MAXIPX = 100 )
27636 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27637 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27638 & IPOIX1,IPOIX2,IPOIX3
27639
27640C standard particle data interface
27641 INTEGER NMXHEP
27642
27643 PARAMETER (NMXHEP=4000)
27644
27645 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27646 DOUBLE PRECISION PHEP,VHEP
27647 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27648 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27649 & VHEP(4,NMXHEP)
27650C extension to standard particle data interface (PHOJET specific)
27651 INTEGER IMPART,IPHIST,ICOLOR
27652 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27653
27654C event weights and generated cross section
27655 INTEGER IPOWGC,ISWCUT,IVWGHT
27656 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27657 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27658 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27659
27660 DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27661 DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27662 DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27663 & IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27664 & IDIR(2),IPROC(2)
27665
27666 IF(IMODE.EQ.-1) THEN
27667C initialization
27668 RETURN
27669 ELSE IF(IMODE.EQ.-2) THEN
27670C output of statistics
27671 RETURN
27672 ENDIF
27673
27674 IREJ = 0
27675C mass cuts
27676 PIMASS = 0.140D0
27677C debug output
27678 IF(IDEB(45).GE.10) THEN
27679 WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27680 & 'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27681 & IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27682 ENDIF
27683 IPAR(1) = IDIF1
27684 IPAR(2) = IDIF2
27685C save current status
27686 MSOFT = 0
27687 MHARD = 0
27688 KHPOMS = KHPOM
27689 KSPOMS = KSPOM
27690 KSREGS = KSREG
27691 KHDIRS = KHDIR
27692 IPOIS1 = IPOIX1
27693 IPOIS2 = IPOIX2
27694 IPOIS3 = IPOIX3
27695 JDA11 = JDAHEP(1,IMOTH1)
27696 JDA21 = JDAHEP(2,IMOTH1)
27697 JDA12 = JDAHEP(1,IMOTH2)
27698 JDA22 = JDAHEP(2,IMOTH2)
27699 ISTH1 = ISTHEP(IMOTH1)
27700 ISTH2 = ISTHEP(IMOTH2)
27701 NHEPS = NHEP
27702C get mother data
27703 NPOSD(1) = IMOTH1
27704 NPOSD(2) = IMOTH2
27705 DO 20 I=1,2
27706 IDPDG(I) = IDHEP(NPOSD(I))
27707 IDBAM(I) = IMPART(NPOSD(I))
27708 AMP(I) = PHO_PMASS(IDBAM(I),0)
27709 IF(IDPDG(I).EQ.22) THEN
27710 PMASSD(I) = 0.765D0
27711 PVIRTD(I) = PHEP(5,NPOSD(I))**2
27712 ELSE
27713 PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27714 PVIRTD(I) = 0.D0
27715 ENDIF
27716 20 CONTINUE
27717C get CM system
27718 P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27719 P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27720 P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27721 P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27722 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27723 ECMD = SQRT(SS)
27724 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27725 & 'PHO_DIFDIS: availabe energy',ECMD
27726C check total available energy
27727 IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27728 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27729 & 'PHO_DIFDIS: ',
27730 & 'not enough energy for inelastic diffraction',
27731 & 'ECM, particle masses:',ECMD,AMP
27732 IFAIL(7) = IFAIL(7)+1
27733 IREJ = 1
27734 RETURN
27735 ENDIF
27736C boost into CMS
27737 DO 10 I=1,4
27738 GAMBED(I) = P1(I)/ECMD
27739 10 CONTINUE
27740 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27741 & PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27742 & PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27743C rotation angles
27744 CODD = P1(3)/PTOT1
27745 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27746 COFD = 1.D0
27747 SIFD = 0.D0
27748 IF(PTOT1*SIDD.GT.1.D-5) THEN
27749 COFD = P1(1)/(SIDD*PTOT1)
27750 SIFD = P1(2)/(SIDD*PTOT1)
27751 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27752 COFD = COFD/ANORF
27753 SIFD = SIFD/ANORF
27754 ENDIF
27755C initial particles in CMS
27756 PDCMS(1,1) = 0.D0
27757 PDCMS(2,1) = 0.D0
27758 PDCMS(3,1) = PTOT1
27759 PDCMS(4,1) = P1(4)
27760 PDCMS(1,2) = 0.D0
27761 PDCMS(2,2) = 0.D0
27762 PDCMS(3,2) = -PTOT1
27763 PDCMS(4,2) = ECMD-P1(4)
27764C get new CM momentum
27765 AM12 = PMASSD(1)**2
27766 AM22 = PMASSD(2)**2
27767 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27768
27769C coherence constraint (min/max diffractive mass allowed)
27770 IF(IMODE.EQ.2) THEN
27771 THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27772 THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27773 THRM2 = SQRT(1-PARMDL(72))*ECMD
27774 THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27775 ELSE
27776 THRM1 = PARMDL(46)
27777 THRM2 = PARMDL(45)*ECMD
27778C check kinematic limits
27779 IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27780 IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27781 ENDIF
27782
27783C check energy vs. coherence constraints
27784 IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27785 IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27786
27787C no phase space available
27788 IF(IPAR(1)+IPAR(2).EQ.0) THEN
27789 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27790 & 'PHO_DIFDIS: ',
27791 & 'not enough phase space for ine. diffraction (Ecm)',ECMD,
27792 & 'side 1: min. mass, upper mass limit:',
27793 & MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27794 & 'side 2: min. mass, upper mass limit:',
27795 & MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27796 IFAIL(7) = IFAIL(7)+1
27797 IREJ = 1
27798 RETURN
27799 ENDIF
27800
27801 ITRY = 0
27802 ITRYM = 10
27803 IPARS1 = IPAR(1)
27804 IPARS2 = IPAR(2)
27805
27806C main rejection loop
27807C -------------------------------
27808 50 CONTINUE
27809 ITRY = ITRY+1
27810 IF(ITRY.GT.1) THEN
27811 IFAIL(13) = IFAIL(13)+1
27812 IF(ITRY.GE.ITRYM) THEN
27813 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27814 & 'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27815 IFAIL(7) = IFAIL(7)+1
27816 IREJ = 1
27817 RETURN
27818 ENDIF
27819 ENDIF
27820 KSPOM = KSPOMS
27821 KHPOM = KHPOMS
27822 KHDIR = KHDIRS
27823 KSREG = KSREGS
27824 IPAR(1) = IPARS1
27825 IPAR(2) = IPARS2
27826C reset mother-daugther relations
27827 NHEP = NHEPS
27828 JDAHEP(1,IMOTH1) = JDA11
27829 JDAHEP(2,IMOTH1) = JDA21
27830 JDAHEP(1,IMOTH2) = JDA12
27831 JDAHEP(2,IMOTH2) = JDA22
27832 ISTHEP(IMOTH1) = ISTH1
27833 ISTHEP(IMOTH2) = ISTH2
27834 IPOIX1 = IPOIS1
27835 IPOIX2 = IPOIS2
27836 IPOIX3 = IPOIS3
27837C
27838 NSLP = 0
27839 NCOR = 0
27840 55 CONTINUE
27841
27842C calculation of kinematics
27843 DO 100 I=1,2
27844C sampling of masses
27845 IRPDG(I) = 0
27846 IRBAM(I) = 0
27847 IFL1P(I) = IDPDG(I)
27848 IFL2P(I) = IDBAM(I)
27849 IVEC(I) = 0
27850 IDIR(I) = 0
27851 ISAM(I) = 0
27852 JSAM(I) = 0
27853 KSAM(I) = 0
27854 IF(IPAR(I).EQ.0) THEN
27855C vector meson dominance assumed
27856 XMASS(I) = AMP(I)
27857 CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27858C diffraction dissociation
27859 ELSE IF(IPAR(I).EQ.1) THEN
27860 XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27861 PREF2 = PMASSD(I)**2
27862 XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27863 ELSE
27864 WRITE(LO,'(/1X,A,2I3)')
27865 & 'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27866 CALL PHO_ABORT
27867 ENDIF
27868 100 CONTINUE
27869
27870C sampling of momentum transfer
27871 CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27872 & THRM2,TT,SLWGHT,IREJ)
27873 IF(IREJ.NE.0) THEN
27874 NSLP=NSLP+1
27875 IF(NSLP.LT.100) GOTO 55
27876 WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27877 & 'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27878 IREJ = 5
27879 RETURN
27880 ENDIF
27881
27882C correct for t-M^2 correlation in diffraction
27883 IF(DT_RNDM(TT).GT.SLWGHT) THEN
27884 NCOR=NCOR+1
27885 IF(NCOR.LT.100) GOTO 55
27886 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27887 & 'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27888 IREJ = 5
27889 RETURN
27890 ENDIF
27891
27892C debug output
27893 IF(IDEB(45).GE.5) THEN
27894 WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27895 & 'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27896 ENDIF
27897C not double pomeron scattering
27898 IF(IMODE.NE.2) THEN
27899C sample diffractive interaction processes
27900 DO 120 I=1,2
27901 IF(IPAR(I).NE.0) THEN
27902C find particle combination
27903 IF(IDPDG(I).EQ.IFPAP(1)) THEN
27904 IP = 2
27905 ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27906 IP = 3
27907 ELSE IF(IDPDG(I).EQ.990) THEN
27908 IP = 4
27909 ELSE
27910 IP = I+1
27911 ENDIF
27912C sample dissociation process
27913 CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27914 & PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27915 & KSAM(I),IDIR(I))
27916 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27917C store process label
27918 IF(IDIR(I).GT.0) THEN
27919 IPAR(I) = 4
27920 ELSE IF(KSAM(I).GT.0) THEN
27921 IPAR(I) = 3
27922 ELSE IF(ISAM(I).GT.0) THEN
27923 IPAR(I) = 2
27924 ELSE
27925 IPAR(I) = 1
27926C mass fine correction
27927 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27928 & XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27929 XMASS(I) = XMNEW
27930 ENDIF
27931 ELSE
27932C diffractive pomeron-hadron interaction
27933 IPAR(I) = 10+IPROC(I)
27934 ENDIF
27935C debug output
27936 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27937 & 'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27938 & IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27939 ENDIF
27940 120 CONTINUE
27941 ENDIF
27942C actualize debug information
27943 IF(IMODE.EQ.1) THEN
27944 IDIFR1 = IPAR(1)
27945 IDIFR2 = IPAR(2)
27946 ENDIF
27947C calculate new momenta in CMS
27948 CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27949 IF(IREJ.NE.0) GOTO 50
27950 DO 130 I=1,4
27951 PP(I,1) = P1(I)
27952 PP(I,2) = P2(I)
27953 130 CONTINUE
27954
27955C comment line for diffraction
27956 CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27957 & XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27958C write diffractive strings/particles
27959 DO 200 I=1,2
27960 I1 = I
27961 I2 = 3-I1
27962 DO K=1,4
27963 PD1(K) = PP(K,I1)
27964 PD2(K) = PP(K,I2)
27965 ENDDO
27966 PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27967 PP(7,I1) = TT
27968 IGEN = IPHIST(2,NPOSD(I1))
27969 if(IGEN.eq.0) IGEN = -I1*10
27970 CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27971 & IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27972 IF(IREJ.NE.0) THEN
27973 IFAIL(7+I) = IFAIL(7+I)+1
27974 IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27975 & 'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27976 & I,IPAR(I),XMASS(I)
27977 GOTO 50
27978 ENDIF
27979 ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27980 200 CONTINUE
27981C double-pomeron scattering?
27982 IF(IMODE.EQ.2) GOTO 150
27983
27984C diffractive final states
27985 DO 300 I=1,2
27986 110 CONTINUE
27987 IF(IPAR(I).EQ.0) THEN
27988C vector meson production
27989 IF(IDPDG(I).EQ.22) THEN
27990 IF(ISWMDL(21).GE.0) THEN
27991 ISP = IPAMDL(3)
27992 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27993 CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27994 ENDIF
27995C hadronic state of multi-pomeron coupling
27996 ELSE IF(IDPDG(I).EQ.990) THEN
27997 CALL PHO_SDECAY(IPOSP(1,I),0,2)
27998 ENDIF
27999 ELSE
28000 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
28001 IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
28002 IF(IDIR(I).GT.0) THEN
28003 IPAR(I) = 4
28004 ELSE IF(KSAM(I).GT.0) THEN
28005 IPAR(I) = 3
28006 ELSE IF(ISAM(I).GT.0) THEN
28007 IPAR(I) = 2
28008 ELSE
28009 IPAR(I) = 1
28010 ENDIF
28011 ELSE
28012 IPAR(I) = 10+IPROC(I)
28013 ENDIF
28014 IPHIST(I,ICPOS) = IPAR(I)
28015C update debug informantion
28016 KSPOM = ISAM(I)
28017 KSREG = JSAM(I)
28018 KHPOM = KSAM(I)
28019 KHDIR = IDIR(I)
28020 IDIFR1 = IPAR(1)
28021 IDIFR2 = IPAR(2)
28022 IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
28023
28024C resonance decay, pi+pi- background
28025 P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
28026 P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
28027 P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
28028 P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
28029 CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
28030 & P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
28031C decay
28032 IF(IDPDG(I).EQ.22) THEN
28033 IPHIST(2,IPOS) = 3
28034 IF(ISWMDL(21).GE.0) THEN
28035 ISP = IPAMDL(3)
28036 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
28037 CALL PHO_SDECAY(IPOS,ISP,2)
28038 ENDIF
28039 ELSE
28040 CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
28041 ENDIF
28042 IREJ = 0
28043 ELSE
28044
28045C particle-pomeron scattering
28046 IF(IPAR(I).LE.4) THEN
28047C non-diffractive particle-pomeron scattering
28048 IGEN = IPHIST(2,NPOSD(I))
28049 if(IGEN.eq.0) then
28050 if(I.eq.1) then
28051 IGEN = 5
28052 else
28053 IGEN = 6
28054 endif
28055 endif
28056 CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
28057 & ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
28058 ELSE
28059C diffractive particle-pomeron scattering
28060 IPOIX2 = IPOIX2+1
28061 IPORES(IPOIX2) = IPROC(I)
28062 IPOPOS(1,IPOIX2) = IPOSP(1,I)
28063 IPOPOS(2,IPOIX2) = IPOSP(2,I)
28064 ENDIF
28065 ENDIF
28066 ENDIF
28067
28068C rejection?
28069 IF(IREJ.NE.0) THEN
28070 IFAIL(20+I) = IFAIL(20+I)+1
28071 IF(IPAR(I).GT.1) THEN
28072 IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
28073 IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
28074 IF(IDIR(I).GT.0) THEN
28075 IDIR(I) = 0
28076 ELSE IF(KSAM(I).GT.0) THEN
28077 KSAM(I) = KSAM(I)-1
28078 ELSE IF(ISAM(I).GT.0) THEN
28079 ISAM(I) = ISAM(I)-1
28080 ENDIF
28081 GOTO 110
28082 ELSE
28083 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28084 & 'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
28085 & I,IPAR(I),XMASS(I)
28086 GOTO 50
28087 ENDIF
28088 ENDIF
28089 300 CONTINUE
28090
28091 IDIF1 = IPAR(1)
28092 IDIF2 = IPAR(2)
28093C update debug information
28094 KSPOM = KSPOMS+ISAM(1)+ISAM(2)
28095 KSREG = KSREGS+JSAM(1)+JSAM(2)
28096 KHPOM = KHPOMS+KSAM(1)+KSAM(2)
28097 KHDIR = KHDIRS+IDIR(1)+IDIR(2)
28098
28099 150 CONTINUE
28100
28101C debug output
28102 IF(IDEB(45).GE.10) THEN
28103 WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
28104 & 'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
28105 & IPAR,NPOSD,MSOFT,MHARD,IMODE
28106 ENDIF
28107 IF(IDEB(45).GE.15) THEN
28108 WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
28109 & '------------------------------'
28110 CALL PHO_PREVNT(0)
28111 ENDIF
28112
28113 END
28114
28115*$ CREATE PHO_DIFPRO.FOR
28116*COPY PHO_DIFPRO
28117CDECK ID>, PHO_DIFPRO
28118 SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
28119 & IPROC,ISAM,JSAM,KSAM,IDIR)
28120C*********************************************************************
28121C
28122C sampling of diffraction dissociation process
28123C
28124C input: IP particle combination
28125C ICUT user imposed limitations
28126C ID1/2 PDG particle code of scattering particles
28127C XMASS diffractively produced mass (GeV)
28128C P2V1/2 virtuality of scattering particles (Gev**2)
28129C SPROB suppression factor for resolved single and
28130C double diffraction dissociation
28131C
28132C output: IRPOC process ID
28133C ISAM number of cut pomerons (soft)
28134C JSAM number of cut reggeons
28135C KSAM number of cut pomerons (hard)
28136C IDIR direct hard interaction
28137C
28138C*********************************************************************
28139 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28140 SAVE
28141
28142C input/output channels
28143 INTEGER LI,LO
28144 COMMON /POINOU/ LI,LO
28145C event debugging information
28146 INTEGER NMAXD
28147 PARAMETER (NMAXD=100)
28148 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28149 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28150 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28151 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28152C general process information
28153 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28154 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28155C model switches and parameters
28156 CHARACTER*8 MDLNA
28157 INTEGER ISWMDL,IPAMDL
28158 DOUBLE PRECISION PARMDL
28159 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28160C energy-interpolation table
28161 INTEGER IEETA2
28162 PARAMETER ( IEETA2 = 20 )
28163 INTEGER ISIMAX
28164 DOUBLE PRECISION SIGTAB,SIGECM
28165 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28166
28167 ISAM = 0
28168 JSAM = 0
28169 KSAM = 0
28170 IDIR = 0
28171
28172 IF(XMASS.GT.3.D0) THEN
28173C rapidity gap survival probability
28174 SPRO = 1.D0
28175 IF(ISWMDL(28).GE.1) SPRO = SPROB
28176C sample interaction
28177 IPROC = 0
28178 CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
28179 ELSE
28180 IPROC = 1
28181 ENDIF
28182 IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
28183C non-diffractive hadron-pomeron interaction
28184 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28185C option for suppression of multiple interaction
28186 IF(ICUT.EQ.0) THEN
28187 IPROC = 1
28188 IF(ISAM+KSAM+IDIR.GT.0) THEN
28189 ISAM = 1
28190 JSAM = 0
28191 ELSE
28192 JSAM = 1
28193 ENDIF
28194 KSAM = 0
28195 IDIR = 0
28196 ELSE IF(ICUT.EQ.1) THEN
28197 IF(IDIR.GT.0) THEN
28198 ELSE IF(KSAM.GT.0) THEN
28199 KSAM = 1
28200 ISAM = 0
28201 JSAM = 0
28202 ELSE IF(ISAM.GT.0) THEN
28203 ISAM = 1
28204 JSAM = 0
28205 ELSE
28206 JSAM = 1
28207 ENDIF
28208 ELSE IF(ICUT.EQ.2) THEN
28209 KSAM = MIN(KSAM,1)
28210 ELSE IF(ICUT.EQ.3) THEN
28211 ISAM = MIN(ISAM,1)
28212 ENDIF
28213 ENDIF
28214 END
28215
28216*$ CREATE PHO_DIFPAR.FOR
28217*COPY PHO_DIFPAR
28218CDECK ID>, PHO_DIFPAR
28219 SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
28220 & IPOSH1,IPOSH2,IMODE,IREJ)
28221C***********************************************************************
28222C
28223C perform string construction for diffraction dissociation
28224C
28225C input: IMOTH1,2 index of mother particles in POEVT1
28226C IGENM production process of mother particles
28227C IFL1,IFL2 particle numbers
28228C (IDPDG,IDBAM for quasi-elas. hadron)
28229C IPAR 0 quasi-elasic scattering
28230C 1 single string configuration
28231C 2 two string configuration
28232C P1 massive 4 momentum of first
28233C P1(6) virtuality/squ.mass of particle (GeV**2)
28234C P1(7) virtuality of Pomeron (neg, GeV**2)
28235C P2 massive 4 momentum of second particle
28236C IMODE 1 diffraction dissociation
28237C 2 double-pomeron scattering
28238C
28239C output: IPOSH1,2 index of the particles in /POEVT1/
28240C IREJ 0 successful string construction
28241C 1 no string construction possible
28242C
28243C***********************************************************************
28244 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28245 SAVE
28246
28247 DIMENSION P1(7),P2(7)
28248
28249 PARAMETER ( EPS = 1.D-7,
28250 & DEPS = 1.D-10)
28251
28252C input/output channels
28253 INTEGER LI,LO
28254 COMMON /POINOU/ LI,LO
28255C event debugging information
28256 INTEGER NMAXD
28257 PARAMETER (NMAXD=100)
28258 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28259 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28260 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28261 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28262C internal rejection counters
28263 INTEGER NMXJ
28264 PARAMETER (NMXJ=60)
28265 CHARACTER*10 REJTIT
28266 INTEGER IFAIL
28267 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28268C c.m. kinematics of diffraction
28269 INTEGER NPOSD
28270 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28271 & SIDD,CODD,SIFD,COFD,PDCMS
28272 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28273 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28274C model switches and parameters
28275 CHARACTER*8 MDLNA
28276 INTEGER ISWMDL,IPAMDL
28277 DOUBLE PRECISION PARMDL
28278 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28279C some constants
28280 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28281 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28282 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28283
28284C standard particle data interface
28285 INTEGER NMXHEP
28286
28287 PARAMETER (NMXHEP=4000)
28288
28289 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28290 DOUBLE PRECISION PHEP,VHEP
28291 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28292 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28293 & VHEP(4,NMXHEP)
28294C extension to standard particle data interface (PHOJET specific)
28295 INTEGER IMPART,IPHIST,ICOLOR
28296 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28297
28298 DIMENSION PCH1(2,4)
28299 data IC1 /0/
28300 data IC2 /0/
28301
28302 IREJ = 0
28303 ILTR1 = NHEP+1
28304 IGEN = IGENM
28305 if(IGENM.le.-10) IGEN = 0
28306
28307C elastic part
28308 IF(IPAR.EQ.0) THEN
28309 IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28310 if(IGEN.eq.0) IGEN = 3
28311C pi+/pi- isotropic background
28312 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28313 & P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28314 CALL PHO_SDECAY(IPOSH1,0,-2)
28315 ELSE
28316 if(IGEN.eq.0) then
28317 IGEN = 2
28318 if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28319 endif
28320C registration of particle or resonance
28321 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28322 & P1(4),0,IGEN,0,0,IPOSH1,1)
28323 ENDIF
28324
28325C diffraction dissociation
28326 ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28327C calculation of resulting particle momenta
28328 IF(IMOTH1.EQ.NPOSD(1)) THEN
28329 K = 2
28330 ELSE
28331 K = 1
28332 ENDIF
28333 DO 100 I=1,4
28334 PCH1(2,I) = PDCMS(I,K)-P2(I)
28335 PCH1(1,I) = P1(I)-PCH1(2,I)
28336 100 CONTINUE
28337
28338C registration
28339 if(IMODE.LT.2) then
28340 if(IGEN.eq.0) IGEN = -IGENM/10+4
28341 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28342 & PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28343 else
28344 if(IGEN.eq.0) IGEN = 4
28345 endif
28346 CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28347 & PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28348
28349C invalid IPAR
28350 ELSE
28351 WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28352 CALL PHO_ABORT
28353 ENDIF
28354
28355C back transformation
28356 CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28357 & GAMBED(1),GAMBED(2),GAMBED(3))
28358
28359 END
28360
28361*$ CREATE PHO_QELAST.FOR
28362*COPY PHO_QELAST
28363CDECK ID>, PHO_QELAST
28364 SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28365C**********************************************************************
28366C
28367C sampling of quasi elastic processes
28368C
28369C input: IPROC 2 purely elastic scattering
28370C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
28371C IPROC 4 double pomeron scattering
28372C IPROC -1 initialization
28373C IPROC -2 output of statistics
28374C JM1/2 index of initial particle 1/2
28375C
28376C output: initial and final particles in /POEVT1/ involving
28377C polarized resonances in /POEVT1/ and decay
28378C products
28379C
28380C IREJ 0 successful
28381C 1 failure
28382C 50 user rejection
28383C
28384C**********************************************************************
28385 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28386 SAVE
28387
28388 PARAMETER ( NTAB = 20,
28389 & EPS = 1.D-10,
28390 & PIMASS = 0.13D0,
28391 & DEPS = 1.D-10)
28392
28393C input/output channels
28394 INTEGER LI,LO
28395 COMMON /POINOU/ LI,LO
28396C event debugging information
28397 INTEGER NMAXD
28398 PARAMETER (NMAXD=100)
28399 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28400 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28401 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28402 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28403C global event kinematics and particle IDs
28404 INTEGER IFPAP,IFPAB
28405 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28406 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28407C c.m. kinematics of diffraction
28408 INTEGER NPOSD
28409 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28410 & SIDD,CODD,SIFD,COFD,PDCMS
28411 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28412 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28413C model switches and parameters
28414 CHARACTER*8 MDLNA
28415 INTEGER ISWMDL,IPAMDL
28416 DOUBLE PRECISION PARMDL
28417 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28418C some constants
28419 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28420 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28421 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28422C cross sections
28423 INTEGER IPFIL,IFAFIL,IFBFIL
28424 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28425 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28426 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28427 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28428 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28429 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28430 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28431 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28432 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28433 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28434 & IPFIL,IFAFIL,IFBFIL
28435
28436C standard particle data interface
28437 INTEGER NMXHEP
28438
28439 PARAMETER (NMXHEP=4000)
28440
28441 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28442 DOUBLE PRECISION PHEP,VHEP
28443 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28444 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28445 & VHEP(4,NMXHEP)
28446C extension to standard particle data interface (PHOJET specific)
28447 INTEGER IMPART,IPHIST,ICOLOR
28448 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28449
28450 DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28451 DIMENSION P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28452 DIMENSION IFL(2),IDPRO(4)
28453 character*15 pho_pname
28454 CHARACTER*8 VMESA(0:4),VMESB(0:4)
28455 DIMENSION ISAMVM(4,4)
28456 DATA IDPRO / 113,223,333,92 /
28457 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
28458 & 'pi+pi- ' /
28459 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
28460 & 'pi+pi- ' /
28461
28462C sampling of elastic/quasi-elastic processes
28463 IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28464 IREJ = 0
28465 NPOSD(1) = JM1
28466 NPOSD(2) = JM2
28467 DO 55 I=1,2
28468 PMI(I) = PHEP(5,NPOSD(I))
28469 IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28470 55 CONTINUE
28471C get CM system
28472 PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28473 PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28474 PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28475 PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28476 SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28477 ECMD = SQRT(SS)
28478
28479 IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28480 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28481 & 'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28482 & ECMD,PMI
28483 IREJ = 5
28484 RETURN
28485 ENDIF
28486
28487 DO 60 I=1,4
28488 GAMBED(I) = PK1(I)/ECMD
28489 60 CONTINUE
28490 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28491 & PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28492 & PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28493C rotation angles
28494 CODD = PK1(3)/PTOT1
28495 SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28496 COFD = 1.D0
28497 SIFD = 0.D0
28498 IF(PTOT1*SIDD.GT.1.D-5) THEN
28499 COFD = PK1(1)/(SIDD*PTOT1)
28500 SIFD = PK1(2)/(SIDD*PTOT1)
28501 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28502 COFD = COFD/ANORF
28503 SIFD = SIFD/ANORF
28504 ENDIF
28505C get CM momentum
28506 AM12 = PMI(1)**2
28507 AM22 = PMI(2)**2
28508 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28509
28510C production process of mother particles
28511 IGEN = IPHIST(2,NPOSD(1))
28512 if(IGEN.eq.0) IGEN = IPROC
28513
28514 ICALL = ICALL + 1
28515C main rejection label
28516 50 CONTINUE
28517C determine process and final particles
28518 IFL(1) = IDHEP(NPOSD(1))
28519 IFL(2) = IDHEP(NPOSD(2))
28520 IF(IPROC.EQ.3) THEN
28521 ITRY = 0
28522 100 CONTINUE
28523 ITRY = ITRY+1
28524 IF(ITRY.GT.50) THEN
28525 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28526 & 'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28527 & ITRY,ECMD
28528 IREJ = 5
28529 RETURN
28530 ENDIF
28531 XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28532 DO 110 I=1,4
28533 DO 120 J=1,4
28534 XI = XI-SIGVM(I,J)
28535 IF(XI.LE.0.D0) GOTO 130
28536 120 CONTINUE
28537 110 CONTINUE
28538 130 CONTINUE
28539 IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28540 IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28541 ISAMVM(I,J) = ISAMVM(I,J)+1
28542 ISAMQE = ISAMQE+1
28543C sample new masses
28544 CALL PHO_SAMASS(IFL(1),RMASS(1))
28545 CALL PHO_SAMASS(IFL(2),RMASS(2))
28546 IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28547 ELSE IF(IPROC.EQ.2) THEN
28548 I = 0
28549 J = 0
28550 ISAMEL = ISAMEL+1
28551 RMASS(1) = PHO_PMASS(NPOSD(1),2)
28552 RMASS(2) = PHO_PMASS(NPOSD(2),2)
28553 ELSE
28554 WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28555 CALL PHO_ABORT
28556 ENDIF
28557C sample momentum transfer
28558 CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28559 & SLWGHT,IREJ)
28560 IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28561 & 'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28562C calculate new momenta
28563 CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28564 IF(IREJ.NE.0) GOTO 50
28565 DO K=1,4
28566 P(K,1) = PK1(K)
28567 P(K,2) = PK2(K)
28568 ENDDO
28569C comment line for elastic/quasi-elastic scattering
28570 CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28571 & TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28572
28573 I1 = NHEP+1
28574C fill /POEVT1/
28575 DO 200 I=1,2
28576 K = 3-I
28577 IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28578C pi+/pi- isotropic background
28579 IGEN = 3
28580 CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28581 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28582 ICOLOR(I,ICPOS) = IPOS
28583 CALL PHO_SDECAY(IPOS,0,-2)
28584 ELSE
28585C registration
28586 IGEN = 2
28587 if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28588 CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28589 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28590 ICOLOR(I,ICPOS) = IPOS
28591 ENDIF
28592 200 CONTINUE
28593 I2 = NHEP
28594C search for vector mesons
28595 DO 300 I=I1,I2
28596C decay according to polarization
28597 IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28598 ISP = IPAMDL(3)
28599 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28600 CALL PHO_SDECAY(I,ISP,2)
28601 ENDIF
28602 300 CONTINUE
28603 I2 = NHEP
28604C back transformation
28605 CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28606 & GAMBED(2),GAMBED(3))
28607
28608C initialization of tables
28609 ELSE IF(IPROC.EQ.-1) THEN
28610 DO 10 I=1,4
28611 DO 20 J=1,4
28612 ISAMVM(I,J) = 0
28613 20 CONTINUE
28614 10 CONTINUE
28615 ISAMEL = 0
28616 ISAMQE = 0
28617 IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28618 IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28619 CALL PHO_SAMASS(-1,RMASS(1))
28620 ICALL = 0
28621
28622C output of statistics
28623 ELSE IF(IPROC.EQ.-2) THEN
28624 IF(ICALL.LT.10) RETURN
28625 WRITE(LO,'(/,1X,A,I10/,1X,A)')
28626 & 'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28627 & '---------------------------------------------------'
28628 WRITE(LO,'(1X,A,I10)')
28629 & 'sampled elastic processes:',ISAMEL
28630 WRITE(LO,'(1X,A,I10)')
28631 & 'sampled quasi-elastic vectormeson production:',ISAMQE
28632 WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28633 DO 30 I=1,4
28634 WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28635 30 CONTINUE
28636 CALL PHO_SAMASS(-2,RMASS(1))
28637 ELSE
28638 WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28639 & 'unknown process ID',IPROC
28640 CALL PHO_ABORT
28641 ENDIF
28642
28643 END
28644
28645*$ CREATE PHO_CDIFF.FOR
28646*COPY PHO_CDIFF
28647CDECK ID>, PHO_CDIFF
28648 SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28649C**********************************************************************
28650C
28651C preparation of /POEVT1/ for double-pomeron scattering
28652C
28653C input: IMOTH1/2 index of mother particles in /POEVT1/
28654C
28655C IMODE 1 sampling of pomeron-pomeron scattering
28656C -1 initialization
28657C -2 output of statistics
28658C
28659C output: MSOFT number of generated soft strings
28660C MHARD number of generated hard strings
28661C IREJ 0 accepted
28662C 1 rejected
28663C 50 user rejection
28664C
28665C**********************************************************************
28666 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28667 SAVE
28668
28669 PARAMETER ( EPS = 1.D-10,
28670 & DEPS = 1.D-10)
28671
28672C input/output channels
28673 INTEGER LI,LO
28674 COMMON /POINOU/ LI,LO
28675C event debugging information
28676 INTEGER NMAXD
28677 PARAMETER (NMAXD=100)
28678 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28679 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28680 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28681 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28682C internal rejection counters
28683 INTEGER NMXJ
28684 PARAMETER (NMXJ=60)
28685 CHARACTER*10 REJTIT
28686 INTEGER IFAIL
28687 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28688C model switches and parameters
28689 CHARACTER*8 MDLNA
28690 INTEGER ISWMDL,IPAMDL
28691 DOUBLE PRECISION PARMDL
28692 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28693C general process information
28694 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28695 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28696C Reggeon phenomenology parameters
28697 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28698 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28699 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28700 & ALREG,ALREGP,GR(2),B0REG(2),
28701 & GPPP,GPPR,B0PPP,B0PPR,
28702 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28703C parameters of 2x2 channel model
28704 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28705 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28706C some constants
28707 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28708 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28709 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28710C energy-interpolation table
28711 INTEGER IEETA2
28712 PARAMETER ( IEETA2 = 20 )
28713 INTEGER ISIMAX
28714 DOUBLE PRECISION SIGTAB,SIGECM
28715 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28716C table of particle indices for recursive PHOJET calls
28717 INTEGER MAXIPX
28718 PARAMETER ( MAXIPX = 100 )
28719 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28720 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28721 & IPOIX1,IPOIX2,IPOIX3
28722
28723C standard particle data interface
28724 INTEGER NMXHEP
28725
28726 PARAMETER (NMXHEP=4000)
28727
28728 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28729 DOUBLE PRECISION PHEP,VHEP
28730 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28731 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28732 & VHEP(4,NMXHEP)
28733C extension to standard particle data interface (PHOJET specific)
28734 INTEGER IMPART,IPHIST,ICOLOR
28735 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28736
28737 DIMENSION PD(4)
28738
28739 if(IMODE.ne.1) return
28740
28741 IREJ = 0
28742 IP = 4
28743C select first diffraction
28744 IF(DT_RNDM(DUM).GT.0.5D0) THEN
28745 IPAR1 = 1
28746 IPAR2 = 0
28747 ELSE
28748 IPAR1 = 0
28749 IPAR2 = 1
28750 ENDIF
28751 ITRY2 = 0
28752 ITRYM = 1000
28753
28754C save current status
28755 MSOFT = 0
28756 MHARD = 0
28757 KHPOMS = KHPOM
28758 KSPOMS = KSPOM
28759 KSREGS = KSREG
28760 KHDIRS = KHDIR
28761 IPOIS1 = IPOIX1
28762 IPOIS2 = IPOIX2
28763 IPOIS3 = IPOIX3
28764 JDA11 = JDAHEP(1,IMOTH1)
28765 JDA21 = JDAHEP(2,IMOTH1)
28766 JDA12 = JDAHEP(1,IMOTH2)
28767 JDA22 = JDAHEP(2,IMOTH2)
28768 ISTH1 = ISTHEP(IMOTH1)
28769 ISTH2 = ISTHEP(IMOTH2)
28770 NHEPS = NHEP
28771
28772C find mother particle production process
28773 IGEN = IPHIST(2,IMOTH1)
28774 if(IGEN.eq.0) IGEN = 4
28775
28776C main generation loop
28777 60 CONTINUE
28778
28779 KSPOM = KSPOMS
28780 KHPOM = KHPOMS
28781 KHDIR = KHDIRS
28782 KSREG = KSREGS
28783 I1 = IPAR1
28784 I2 = IPAR2
28785C reset mother-daugther relations
28786 NHEP = NHEPS
28787 JDAHEP(1,IMOTH1) = JDA11
28788 JDAHEP(2,IMOTH1) = JDA21
28789 JDAHEP(1,IMOTH2) = JDA12
28790 JDAHEP(2,IMOTH2) = JDA22
28791 ISTHEP(IMOTH1) = ISTH1
28792 ISTHEP(IMOTH2) = ISTH2
28793 IPOIX1 = IPOIS1
28794 IPOIX2 = IPOIS2
28795 IPOIX3 = IPOIS3
28796C rejection counter
28797 ITRY2 = ITRY2+1
28798 IF(ITRY2.GT.1) THEN
28799 IFAIL(39) = IFAIL(39)+1
28800 IF(ITRY2.GE.ITRYM) GOTO 50
28801 ENDIF
28802C generate two diffractive events
28803 CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28804 IF(IREJ.NE.0) GOTO 50
28805 CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28806 IF(IREJ.NE.0) GOTO 50
28807C mass of pomeron-pomeron system
28808 DO 100 I2 = NHEP,1,-1
28809 IF(IDHEP(I2).EQ.990) GOTO 110
28810 100 CONTINUE
28811 110 CONTINUE
28812 DO 120 I1 = I2-1,1,-1
28813 IF(IDHEP(I1).EQ.990) GOTO 130
28814 120 CONTINUE
28815 130 CONTINUE
28816 DO 140 I=1,4
28817 PD(I) = PHEP(I,I1)+PHEP(I,I2)
28818 140 CONTINUE
28819 XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28820 IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28821 & 'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28822 IF(XMASS.LT.0.1D0) GOTO 60
28823 XMASS = SQRT(XMASS)
28824 IF(XMASS.LT.PARMDL(71)) GOTO 60
28825
28826C sample pomeron-pomeron interaction process
28827 CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28828 & IPROC,ISAM,JSAM,KSAM,IDIR)
28829
28830C non-diffractive pomeron-pomeron interactions
28831 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28832 200 CONTINUE
28833 IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28834C debug output
28835 IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28836 & 'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28837 & IP,XMASS,ISAM,JSAM,KSAM,IDIR
28838C store debug information
28839 IF(IDIR.GT.0) THEN
28840 IPAR = 4
28841 ELSE IF(KSAM.GT.0) THEN
28842 IPAR = 3
28843 ELSE IF(ISAM.GT.0) THEN
28844 IPAR = 2
28845 ELSE
28846 IPAR = 1
28847 ENDIF
28848 IDDPOM = IPAR
28849 IF(ISAM+JSAM.GT.0) KSDPO = 1
28850 IF(KSAM+IDIR.GT.0) KHDPO = 1
28851 KSPOM = ISAM
28852 KSREG = JSAM
28853 KHPOM = KSAM
28854 KHDIR = IDIR
28855 KSTRG = 0
28856 KSLOO = 0
28857C generate pomeron-pomeron interaction
28858 CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28859 IF(IREJ.NE.0) THEN
28860 IFAIL(3) = IFAIL(3)+1
28861 IF(IPAR.GT.1) THEN
28862 IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28863 IF(IDIR.GT.0) THEN
28864 IFAIL(10) = IFAIL(10)+1
28865 IDIR = 0
28866 ELSE IF(KSAM.GT.0) THEN
28867 KSAM = KSAM-1
28868 ELSE IF(ISAM.GT.0) THEN
28869 ISAM = ISAM-1
28870 ENDIF
28871 GOTO 200
28872 ELSE
28873 IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28874 & 'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28875 & I,IPAR,XMASS
28876 GOTO 50
28877 ENDIF
28878 ENDIF
28879
28880C diffractive pomeron-pomeron interactions
28881 ELSE
28882 IPOIX2 = IPOIX2+1
28883 IPORES(IPOIX2) = IPROC
28884 IPOPOS(1,IPOIX2) = I1
28885 IPOPOS(2,IPOIX2) = I2
28886 IPAR = 10+IPROC
28887 IDDPOM = IPAR
28888 ENDIF
28889
28890C update debug information
28891 KSPOM = KSPOMS+ISAM
28892 KSREG = KSREGS+JSAM
28893 KHPOM = KHPOMS+KSAM
28894 KHDIR = KHDIRS+IDIR
28895C comment line for central diffraction
28896 CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28897 & I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28898 PHEP(5,IPOS) = XMASS
28899C debug output
28900 IF(IDEB(59).GE.15) THEN
28901 WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28902 & '-----------------------------'
28903 CALL PHO_PREVNT(0)
28904 ENDIF
28905 RETURN
28906
28907C treatment of rejection
28908 50 CONTINUE
28909 IREJ = 1
28910 IFAIL(40) = IFAIL(40)+1
28911 IF(IDEB(59).GE.3) THEN
28912 WRITE(LO,'(1X,A)')
28913 & 'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28914 IF(IDEB(59).GE.10) THEN
28915 CALL PHO_PREVNT(0)
28916 ELSE
28917 CALL PHO_PREVNT(-1)
28918 ENDIF
28919 ENDIF
28920
28921 END
28922
28923*$ CREATE PHO_SAMASS.FOR
28924*COPY PHO_SAMASS
28925CDECK ID>, PHO_SAMASS
28926 SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28927C**********************************************************************
28928C
28929C resonance mass sampling of quasi elastic processes
28930C
28931C input: IFLA PDG number of particle
28932C IFLA -1 initialization
28933C IFLA -2 output of statistics
28934C
28935C output: RMASS particle mass (in GeV)
28936C
28937C**********************************************************************
28938 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28939 SAVE
28940
28941 PARAMETER(EPS = 1.D-10 )
28942
28943C input/output channels
28944 INTEGER LI,LO
28945 COMMON /POINOU/ LI,LO
28946C event debugging information
28947 INTEGER NMAXD
28948 PARAMETER (NMAXD=100)
28949 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28950 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28951 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28952 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28953C model switches and parameters
28954 CHARACTER*8 MDLNA
28955 INTEGER ISWMDL,IPAMDL
28956 DOUBLE PRECISION PARMDL
28957 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28958C parameters of the "simple" Vector Dominance Model
28959 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28960 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28961
28962 PARAMETER(NTABM=50)
28963 DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28964 DIMENSION SUM(4),ICALL(4)
28965
28966C*****************************************************************
28967C initialization of tables
28968 IF(IFLA.EQ.-1) THEN
28969C
28970 NSTEP = NTABM
28971 DO 102 I=1,4
28972 ICALL(I) = 0
28973
28974 DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28975 DO 105 K=1,NSTEP
28976 RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28977 105 CONTINUE
28978 102 CONTINUE
28979C calculate table of dsig/dm
28980 CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28981C output of table
28982 IF(IDEB(35).GE.1) THEN
28983 WRITE(LO,'(/5X,A)') 'table: mass (GeV) DSIG/DM (mub/GeV)'
28984 WRITE(LO,'(1X,A,/1X,A)')
28985 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28986 & ' -------------------------------------------------------'
28987 DO 106 K=1,NSTEP
28988 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28989 & RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28990 106 CONTINUE
28991 ENDIF
28992C make second table for sampling
28993 DO 109 I=1,4
28994 SUM(I) = 0.D0
28995 DO 108 K=2,NSTEP
28996 SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
28997 XMC(I,K) = SUM(I)
28998 108 CONTINUE
28999 109 CONTINUE
29000C normalization
29001 DO 118 K=1,NSTEP
29002 DO 119 I=1,4
29003 XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
29004 119 CONTINUE
29005 118 CONTINUE
29006 IF(IDEB(35).GE.10) THEN
29007 WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
29008 WRITE(LO,'(1X,A,/1X,A)')
29009 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
29010 & ' -------------------------------------------------------'
29011 DO 120 K=1,NSTEP
29012 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
29013 & RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
29014 120 CONTINUE
29015 ENDIF
29016C
29017C**************************************************
29018C output of statistics
29019 ELSE IF(IFLA.EQ.-2) THEN
29020 WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
29021 & '----------------------'
29022 WRITE(LO,'(4(/8X,A,I10))') 'rho: ',ICALL(1),
29023 & 'omega: ',ICALL(2),'phi: ',ICALL(3),'pi+pi-:',ICALL(4)
29024
29025C
29026C********************************************************
29027C sampling of RMASS
29028 ELSE
29029C quasi-elastic vector meson production
29030 IF(IFLA.EQ.113) THEN
29031 KP = 1
29032 ELSE IF(IFLA.EQ.223) THEN
29033 KP = 2
29034 ELSE IF(IFLA.EQ.333) THEN
29035 KP = 3
29036 ELSE IF(IFLA.EQ.92) THEN
29037 KP = 4
29038C quasi-elastic production of h*
29039 ELSE IF(IFLA.EQ.91) THEN
29040 RMASS = 0.35D0
29041 RETURN
29042C elastic hadron scattering
29043 ELSE
29044 RMASS = PHO_PMASS(IFLA,1)
29045 IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
29046 & 'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
29047 RETURN
29048 ENDIF
29049C
29050C sample mass of vector mesonsn / two-pi background
29051 XI = DT_RNDM(RMASS) + EPS
29052C binary search
29053 IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
29054 KMIN=1
29055 KMAX=NSTEP
29056 300 CONTINUE
29057 IF((KMAX-KMIN).EQ.1) GOTO 400
29058 KK=(KMAX+KMIN)/2
29059 IF(XI.LE.XMC(KP,KK)) THEN
29060 KMAX=KK
29061 ELSE
29062 KMIN=KK
29063 ENDIF
29064 GOTO 300
29065 400 CONTINUE
29066 ELSE
29067 WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
29068 WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
29069 & KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
29070 CALL PHO_ABORT
29071 ENDIF
29072C fine interpolation
29073 RMASS = RMA(KP,KMIN)+
29074 & (RMA(KP,KMAX)-RMA(KP,KMIN))/
29075 & (XMC(KP,KMAX)-XMC(KP,KMIN))
29076 & *(XI-XMC(KP,KMIN))
29077 IF(IDEB(35).GE.20) THEN
29078 IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
29079 & 'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
29080 & RMA(KP,KMIN),RMA(KP,KMAX),RMASS
29081 WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
29082 & IFLA,RMASS
29083 ENDIF
29084 ICALL(KP) = ICALL(KP)+1
29085
29086 ENDIF
29087 END
29088
29089*$ CREATE PHO_DSIGDM.FOR
29090*COPY PHO_DSIGDM
29091CDECK ID>, PHO_DSIGDM
29092 SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
29093C**********************************************************************
29094C
29095C differential cross section DSIG/DM of low mass enhancement
29096C
29097C input: RMA(4,NTABM) mass values
29098C output: XMA(4,NTABM) DSIG/DM of resonances
29099C 1 rho production
29100C 2 omega production
29101C 3 phi production
29102C 4 pi-pi continuum
29103C
29104C**********************************************************************
29105 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29106 SAVE
29107
29108 PARAMETER ( EPS = 1.D-10 )
29109
29110 PARAMETER(NTABM=50)
29111 DIMENSION XMA(4,NTABM),RMA(4,NTABM)
29112
29113C input/output channels
29114 INTEGER LI,LO
29115 COMMON /POINOU/ LI,LO
29116C event debugging information
29117 INTEGER NMAXD
29118 PARAMETER (NMAXD=100)
29119 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29120 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29121 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29122 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29123C model switches and parameters
29124 CHARACTER*8 MDLNA
29125 INTEGER ISWMDL,IPAMDL
29126 DOUBLE PRECISION PARMDL
29127 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29128C parameters of the "simple" Vector Dominance Model
29129 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29130 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29131
29132 PIMASS = 0.135
29133C rho meson shape (mass dependent width)
29134 QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
29135 DO 100 I=1,NSTEP
29136 XMASS = RMA(1,I)
29137 QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
29138 GAMMA = GAMM(1)*(QQ/QRES)**3
29139 XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
29140 & /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
29141 100 CONTINUE
29142C omega/phi meson (constant width)
29143 DO 200 K=2,3
29144 DO 300 I=1,NSTEP
29145 XMASS = RMA(K,I)
29146 XMA(K,I) = XMASS*GAMM(K)
29147 & /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
29148 300 CONTINUE
29149 200 CONTINUE
29150C pi-pi continuum
29151 DO 400 I=1,NSTEP
29152 XMASS = RMA(4,I)
29153 XMA(4,I) = (XMASS-0.29D0)**2/XMASS
29154 400 CONTINUE
29155
29156 END
29157
29158*$ CREATE PHO_SDECAY.FOR
29159*COPY PHO_SDECAY
29160CDECK ID>, PHO_SDECAY
29161 SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
29162C**********************************************************************
29163C
29164C decay of single resonance of /POEVT1/:
29165C decay in helicity frame according to polarization, isotropic
29166C decay and decay with limited transverse phase space possible
29167C
29168C ATTENTION:
29169C reference to particle number of CPC has to exist
29170C
29171C input: NPOS position in /POEVT1/
29172C ISP 0 decay according to phase space
29173C 1 decay according to transversal polarization
29174C 2 decay according to longitudinal polarization
29175C 3 decay with limited phase space
29176C ILEV decay mode to use
29177C 1 strong only
29178C 2 strong and ew of tau, charm, and bottom
29179C 3 strong and electro-weak decays
29180C negative: remove mother resonance after decay
29181C
29182C output: /POEVT1/,/POEVT2/ final particles according to decay mode
29183C
29184C**********************************************************************
29185 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29186 SAVE
29187
29188 PARAMETER ( EPS = 1.D-15,
29189 & DEPS = 1.D-10 )
29190
29191C input/output channels
29192 INTEGER LI,LO
29193 COMMON /POINOU/ LI,LO
29194C event debugging information
29195 INTEGER NMAXD
29196 PARAMETER (NMAXD=100)
29197 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29198 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29199 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29200 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29201C model switches and parameters
29202 CHARACTER*8 MDLNA
29203 INTEGER ISWMDL,IPAMDL
29204 DOUBLE PRECISION PARMDL
29205 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29206C some constants
29207 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29208 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29209 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29210
29211C standard particle data interface
29212 INTEGER NMXHEP
29213
29214 PARAMETER (NMXHEP=4000)
29215
29216 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
29217 DOUBLE PRECISION PHEP,VHEP
29218 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
29219 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
29220 & VHEP(4,NMXHEP)
29221C extension to standard particle data interface (PHOJET specific)
29222 INTEGER IMPART,IPHIST,ICOLOR
29223 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
29224
29225C general particle data
29226 double precision xm_list,tau_list,gam_list,
29227 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29228 & xm_bb82_list,xm_bb102_list
29229 integer ich3_list,iba3_list,iq_list,
29230 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
29231 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29232 & xm_psm2_list(6,6),xm_vem2_list(6,6),
29233 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29234 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29235 & ich3_list(300),iba3_list(300),iq_list(3,300),
29236 & id_psm_list(6,6),id_vem_list(6,6),
29237 & id_b8_list(6,6,6),id_b10_list(6,6,6)
29238C particle decay data
29239 double precision wg_sec_list
29240 integer idec_list,isec_list
29241 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
29242 & isec_list(3,500)
29243C auxiliary data for three particle decay
29244 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29245 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29246
29247 DIMENSION WGHD(20),KCH(20),ID(3)
29248
29249 IMODE = ABS(ILEV)
29250 IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
29251 & 'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
29252
29253C comment entry
29254 IF(ISTHEP(NPOS).GT.11) RETURN
29255
29256C particle stable?
29257 IDcpc = IMPART(NPOS)
29258 IF(IDcpc.EQ.0) return
29259 IDabs = iabs(IDcpc)
29260 if(idec_list(1,IDabs).eq.0) return
29261
29262C different decay modi (times)
29263 IF(IMODE.EQ.1) THEN
29264 if(idec_list(1,IDabs).ne.1) return
29265 ELSE IF(IMODE.EQ.2) THEN
29266 if(idec_list(1,IDabs).gt.2) return
29267 ELSE IF(IMODE.EQ.3) THEN
29268 if(idec_list(1,IDabs).gt.3) return
29269 ELSE
29270 WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
29271 CALL PHO_ABORT
29272 ENDIF
29273
29274C decay products, check for mass limitations
29275 K = 0
29276 WGSUM = 0.D0
29277 AMIST = PHEP(5,NPOS)
29278 DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
29279 AMSUM = 0.D0
29280 DO 200 L=1,3
29281 ID(L) = isec_list(L,I)
29282 IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
29283 200 CONTINUE
29284 IF(AMSUM.LT.AMIST) THEN
29285 K = K+1
29286 WGHD(K) = wg_sec_list(I)
29287 KCH(K) = I
29288 ENDIF
29289 100 CONTINUE
29290 IF(K.EQ.0)THEN
29291 WRITE(LO,'(/1X,A,I6,3E12.4)')
29292 & 'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29293 & NPOS,AMIST,AMSUM
29294 CALL PHO_PREVNT(0)
29295 RETURN
29296 ENDIF
29297
29298C sample new decay channel
29299 XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29300 K = 0
29301 WGSUM = 0.D0
29302 500 CONTINUE
29303 K = K+1
29304 WGSUM = WGSUM+WGHD(K)
29305 IF(XI.GT.WGSUM) GOTO 500
29306 IK = KCH(K)
29307 ID(1) = isec_list(1,IK)
29308 ID(2) = isec_list(2,IK)
29309 ID(3) = isec_list(3,IK)
29310 if(IDcpc.lt.0) then
29311 ID(1) = ipho_anti(ID(1))
29312 ID(2) = ipho_anti(ID(2))
29313 if(ID(3).ne.0) ID(3) = ipho_anti(ID(3))
29314 endif
29315
29316C rotation
29317 PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29318 CXS = PHEP(1,NPOS)/PTOT
29319 CYS = PHEP(2,NPOS)/PTOT
29320 CZS = PHEP(3,NPOS)/PTOT
29321C boost
29322 GBET = PTOT/AMIST
29323 GAM = PHEP(4,NPOS)/AMIST
29324
29325 IF(ID(3).EQ.0) THEN
29326C two particle decay
29327 CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29328 ELSE
29329C three particle decay
29330 CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29331 & pho_pmass(ID(3),0),ISP)
29332 ENDIF
29333
29334 IF(ILEV.LT.0) THEN
29335 IF(NHEP.NE.NPOS) THEN
29336 WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29337 & 'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29338 CALL PHO_ABORT
29339 ENDIF
29340 IMO1 = JMOHEP(1,NPOS)
29341 IMO2 = JMOHEP(2,NPOS)
29342 NHEP = NHEP-1
29343 ELSE
29344 IMO1 = NPOS
29345 IMO2 = 0
29346 ENDIF
29347 IPH1 = IPHIST(1,NPOS)
29348 IPH2 = IPHIST(2,NPOS)
29349
29350C back transformation and registration
29351 DO 300 I=1,3
29352 IF(ID(I).NE.0) THEN
29353 CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29354 & PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29355 XX = PTOT*CX
29356 YY = PTOT*CY
29357 ZZ = PTOT*CZ
29358 CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29359 & IPH1,IPH2,0,0,IPOS,1)
29360 ENDIF
29361 300 CONTINUE
29362
29363 400 CONTINUE
29364C debug output
29365 IF(IDEB(36).GE.20) THEN
29366 WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29367 & '--------------------'
29368 CALL PHO_PREVNT(0)
29369 ENDIF
29370
29371 END
29372
29373*$ CREATE PHO_SDECY2.FOR
29374*COPY PHO_SDECY2
29375CDECK ID>, PHO_SDECY2
29376 SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29377C**********************************************************************
29378C
29379C isotropic/anisotropic two particle decay in CM system,
29380C (transversely/longitudinally polarized boson into two
29381C pseudo-scalar mesons)
29382C
29383C**********************************************************************
29384 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29385 SAVE
29386
29387C input/output channels
29388 INTEGER LI,LO
29389 COMMON /POINOU/ LI,LO
29390C auxiliary data for three particle decay
29391 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29392 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29393
29394 UMO2=UMO*UMO
29395 AM11=AM1*AM1
29396 AM22=AM2*AM2
29397 ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29398 ECM(2)=UMO-ECM(1)
29399 WAU=ECM(1)*ECM(1)-AM11
29400 IF(WAU.LT.0.D0) THEN
29401 WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29402 CALL PHO_ABORT
29403 ENDIF
29404 PCM(1)=SQRT(WAU)
29405 PCM(2)=PCM(1)
29406
29407 CALL PHO_SFECFE(SIF(1),COF(1))
29408 IF(ISP.EQ.0) THEN
29409C no polarization
29410 COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
29411 ELSE IF(ISP.EQ.1) THEN
29412C transverse polarization
29413 400 CONTINUE
29414 COD(1) = 2.D0*DT_RNDM(AM22)-1.D0
29415 SID12 = 1.D0-COD(1)*COD(1)
29416 IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29417 ELSE IF(ISP.EQ.2) THEN
29418C longitudinal polarization
29419 500 CONTINUE
29420 COD(1) = 2.D0*DT_RNDM(AM2)-1.D0
29421 COD12 = COD(1)*COD(1)
29422 IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29423 ELSE
29424 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29425 & 'invalid polarization',ISP
29426 CALL PHO_ABORT
29427 ENDIF
29428
29429 COD(2) = -COD(1)
29430 COF(2) = -COF(1)
29431 SIF(2) = -SIF(1)
29432
29433 END
29434
29435*$ CREATE PHO_SDECY3.FOR
29436*COPY PHO_SDECY3
29437CDECK ID>, PHO_SDECY3
29438 SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29439C**********************************************************************
29440C
29441C isotropic/anisotropic three particle decay in CM system,
29442C (transversely/longitudinally polarized boson into three
29443C pseudo-scalar mesons)
29444C
29445C**********************************************************************
29446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29447 SAVE
29448
29449 PARAMETER ( DEPS = 1.D-30,
29450 & EPS = 1.D-15 )
29451
29452C input/output channels
29453 INTEGER LI,LO
29454 COMMON /POINOU/ LI,LO
29455C auxiliary data for three particle decay
29456 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29457 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29458
29459 DIMENSION F(5),XX(5)
29460
29461C calculation of maximum of S2 phase space weight
29462 UMOO=UMO+UMO
29463 GU=(AM2+AM3)**2
29464 GO=(UMO-AM1)**2
29465 UFAK=1.0000000000001D0
29466 IF (GU.GT.GO) UFAK=0.99999999999999D0
29467 OFAK=2.D0-UFAK
29468 GU=GU*UFAK
29469 GO=GO*OFAK
29470 DS2=(GO-GU)/99.D0
29471 AM11=AM1*AM1
29472 AM22=AM2*AM2
29473 AM33=AM3*AM3
29474 UMO2=UMO*UMO
29475 RHO2=0.D0
29476 S22=GU
29477 DO 124 I=1,100
29478 S21=S22
29479 S22=GU+(I-1.D0)*DS2
29480 RHO1=RHO2
29481 RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29482 IF(RHO2.LT.RHO1) GOTO 125
29483 124 CONTINUE
29484
29485 125 CONTINUE
29486 S2SUP=(S22-S21)/2.D0+S21
29487 SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29488 & /(S2SUP+EPS)
29489 SUPRHO=SUPRHO*1.05D0
29490 XO=S21-DS2
29491 IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29492 IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29493 XX(1)=XO
29494 XX(3)=S22
29495 X1=(XO+S22)*0.5D0
29496 XX(2)=X1
29497 F(3)=RHO2
29498 F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29499 F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29500 DO 126 I=1,16
29501 X4=(XX(1)+XX(2))*0.5D0
29502 X5=(XX(2)+XX(3))*0.5D0
29503 F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29504 F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29505 XX(4)=X4
29506 XX(5)=X5
29507 DO 128 II=1,5
29508 IA=II
29509 DO 131 III=IA,5
29510 IF(F(II).LT.F(III)) THEN
29511 FH=F(II)
29512 F(II)=F(III)
29513 F(III)=FH
29514 FH=XX(II)
29515 XX(II)=XX(III)
29516 XX(III)=FH
29517 ENDIF
29518 131 CONTINUE
29519 128 CONTINUE
29520 SUPRHO=F(1)
29521 S2SUP=XX(1)
29522 DO 129 II=1,3
29523 IA=II
29524 DO 130 III=IA,3
29525 IF (XX(II).LT.XX(III)) THEN
29526 FH=F(II)
29527 F(II)=F(III)
29528 F(III)=FH
29529 FH=XX(II)
29530 XX(II)=XX(III)
29531 XX(III)=FH
29532 ENDIF
29533 130 CONTINUE
29534 129 CONTINUE
29535 126 CONTINUE
29536
29537 AM23=(AM2+AM3)**2
29538
29539C selection of S1
29540 ITH=0
29541 200 CONTINUE
29542 ITH=ITH+1
29543 IF(ITH.GT.200) THEN
29544 WRITE(LO,'(/1X,A,I10)')
29545 & 'PHO_SDECY3:ERROR: too many iterations',ITH
29546 CALL PHO_ABORT
29547 ENDIF
29548 S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29549 Y=DT_RNDM(AM23)*SUPRHO
29550 RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29551 IF(Y.GT.RHO) GOTO 200
29552
29553C selection of S2
29554 S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29555 & /(2.D0*S2)-RHO/2.D0
29556 S3=UMO2+AM11+AM22+AM33-S1-S2
29557 ECM(1)=(UMO2+AM11-S2)/UMOO
29558 ECM(2)=(UMO2+AM22-S3)/UMOO
29559 ECM(3)=(UMO2+AM33-S1)/UMOO
29560 PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29561 PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29562 PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29563
29564C calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29565 IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29566 COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29567 ELSE
29568 COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29569 ENDIF
29570 COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29571 & /(2.D0*PCM(2)*PCM(3))
29572 SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29573 SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29574 COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29575
29576C selection of the sperical coordinates of particle 3
29577 CALL PHO_SFECFE(SIF(3),COF(3))
29578 IF(ISP.EQ.0) THEN
29579C no polarization
29580 COD(3) = 2.D0*DT_RNDM(S2)-1.D0
29581 ELSE IF(ISP.EQ.1) THEN
29582C transverse polarization
29583 400 CONTINUE
29584 COD(3) = 2.D0*DT_RNDM(S1)-1.D0
29585 SID32 = 1.D0-COD(3)*COD(3)
29586 IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29587 ELSE IF(ISP.EQ.2) THEN
29588C longitudinal polarization
29589 500 CONTINUE
29590 COD(3) = 2.D0*DT_RNDM(COSTH2)-1.D0
29591 COD32 = COD(3)*COD(3)
29592 IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29593 ELSE
29594 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29595 & 'invalid polarization',ISP
29596 CALL PHO_ABORT
29597 ENDIF
29598
29599C selection of the rotation angle of p1-p2 plane along p3
29600 IF(ISP.EQ.0) THEN
29601 CALL PHO_SFECFE(SFE,CFE)
29602 ELSE
29603 SFE = 0.D0
29604 CFE = 1.D0
29605 ENDIF
29606 CX11=-COSTH1
29607 CY11=SINTH1*CFE
29608 CZ11=SINTH1*SFE
29609 CX22=-COSTH2
29610 CY22=-SINTH2*CFE
29611 CZ22=-SINTH2*SFE
29612
29613 SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29614 COD(1)=CX11*COD(3)+CZ11*SID3
29615 IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29616 WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29617 & COD(1),COF(3),SID3,CX11,CZ11
29618 CALL PHO_PREVNT(-1)
29619 ENDIF
29620
29621 SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29622 COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29623 SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29624 COD(2)=CX22*COD(3)+CZ22*SID3
29625 SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29626 COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29627 SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29628
29629 END
29630
29631*$ CREATE PHO_DFMASS.FOR
29632*COPY PHO_DFMASS
29633CDECK ID>, PHO_DFMASS
29634 DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29635C**********************************************************************
29636C
29637C sampling of Mx diffractive mass distribution within
29638C limits XMIN, XMAX
29639C
29640C input: XMIN,XMAX mass limitations (GeV)
29641C PREF2 original particle mass/ reference mass
29642C (squared, GeV**2)
29643C PVIRT2 particle virtuality
29644C IMODE M**2 mass distribution
29645C 1 1/(M**2+Q**2)
29646C 2 1/(M**2+Q**2)**alpha
29647C -1 1/(M**2-Mref**2+Q**2)
29648C -2 1/(M**2-Mref**2+Q**2)**alpha
29649C
29650C output: diffractive mass (GeV)
29651C
29652C**********************************************************************
29653 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29654 SAVE
29655
29656 PARAMETER(EPS = 1.D-10)
29657
29658C input/output channels
29659 INTEGER LI,LO
29660 COMMON /POINOU/ LI,LO
29661C event debugging information
29662 INTEGER NMAXD
29663 PARAMETER (NMAXD=100)
29664 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29665 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29666 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29667 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29668C model switches and parameters
29669 CHARACTER*8 MDLNA
29670 INTEGER ISWMDL,IPAMDL
29671 DOUBLE PRECISION PARMDL
29672 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29673C some constants
29674 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29675 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29676 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29677
29678 IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29679 WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29680 & 'invalid mass limits',XMIN,XMAX,PREF2
29681 CALL PHO_PREVNT(-1)
29682 PHO_DFMASS = 0.135D0
29683 RETURN
29684 ENDIF
29685
29686 IF(IMODE.GT.0) THEN
29687 PM2 = -PVIRT2
29688 ELSE
29689 PM2 = PREF2 - PVIRT2
29690 ENDIF
29691
29692C critical pomeron
29693 IF(ABS(IMODE).EQ.1) THEN
29694 XMIN2 = LOG(XMIN**2-PM2)
29695 XMAX2 = LOG(XMAX**2-PM2)
29696 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29697 XMA2 = EXP(XI)+PM2
29698
29699C supercritical pomeron
29700 ELSE IF(ABS(IMODE).EQ.2) THEN
29701 DDELTA = 1.D0-PARMDL(48)
29702 XMIN2 = (XMIN**2-PM2)**DDELTA
29703 XMAX2 = (XMAX**2-PM2)**DDELTA
29704 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29705 XMA2 = XI**(1.D0/DDELTA)+PM2
29706 ELSE
29707 WRITE(LO,'(/,1X,A,I3)')
29708 & 'PHO_DFMASS:ERROR: unsupported mode',IMODE
29709 CALL PHO_ABORT
29710 ENDIF
29711
29712 PHO_DFMASS = SQRT(XMA2)
29713C debug output
29714 IF(IDEB(43).GE.15) THEN
29715 WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29716 & XMIN,XMAX,PREF2,SQRT(XMA2)
29717 ENDIF
29718
29719 END
29720
29721*$ CREATE PHO_DIFSLP.FOR
29722*COPY PHO_DIFSLP
29723CDECK ID>, PHO_DIFSLP
29724 SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29725 & TT,SLWGHT,IREJ)
29726C**********************************************************************
29727C
29728C sampling of T (Mandelstam variable) distribution within
29729C certain limits TMIN, TMAX
29730C
29731C input: IDF1,2 type of diffractive vertex
29732C 0 elastic/quasi-elastic scattering
29733C 1 diffraction dissociation
29734C IVEC1,2 vector meson IDs in case of quasi-elastic
29735C scattering, otherwise 0
29736C XM1 mass of diffractive system 1 (GeV)
29737C XM2 mass of diffractive system 2 (GeV)
29738C XMX max. mass of diffractive system (GeV)
29739C
29740C output: TT squared momentum transfer ( < 0, GeV**2)
29741C SLWGHT weight to allow for mass-dependent slope
29742C IREJ 0 successful sampling
29743C 1 masses too big for given T range
29744C
29745C**********************************************************************
29746 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29747 SAVE
29748
29749 PARAMETER(EPS = 1.D-10)
29750
29751C input/output channels
29752 INTEGER LI,LO
29753 COMMON /POINOU/ LI,LO
29754C event debugging information
29755 INTEGER NMAXD
29756 PARAMETER (NMAXD=100)
29757 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29758 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29759 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29760 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29761C model switches and parameters
29762 CHARACTER*8 MDLNA
29763 INTEGER ISWMDL,IPAMDL
29764 DOUBLE PRECISION PARMDL
29765 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29766C internal rejection counters
29767 INTEGER NMXJ
29768 PARAMETER (NMXJ=60)
29769 CHARACTER*10 REJTIT
29770 INTEGER IFAIL
29771 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29772C c.m. kinematics of diffraction
29773 INTEGER NPOSD
29774 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29775 & SIDD,CODD,SIFD,COFD,PDCMS
29776 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29777 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29778C cross sections
29779 INTEGER IPFIL,IFAFIL,IFBFIL
29780 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29781 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29782 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29783 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29784 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29785 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29786 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29787 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29788 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29789 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29790 & IPFIL,IFAFIL,IFBFIL
29791C Reggeon phenomenology parameters
29792 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29793 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29794 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29795 & ALREG,ALREGP,GR(2),B0REG(2),
29796 & GPPP,GPPR,B0PPP,B0PPR,
29797 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29798C parameters of 2x2 channel model
29799 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29800 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29801C parameters of the "simple" Vector Dominance Model
29802 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29803 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29804C some constants
29805 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29806 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29807 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29808
29809 IREJ = 0
29810 XM12 = XM1**2
29811 XM22 = XM2**2
29812 SS = ECMD**2
29813C
29814C range of momentum transfer t
29815 TMIN = -PARMDL(68)
29816 TMAX = -PARMDL(69)
29817C determine min. abs(t) necessary to produce masses
29818 PCM2 = PCMD**2
29819 PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29820 IF(PCMP2.LE.0.D0) THEN
29821 IREJ = 1
29822 TT = 0.D0
29823 RETURN
29824 ENDIF
29825 TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29826 & -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29827C
29828 IF(TMINP.LT.TMAX) THEN
29829 IF(IDEB(44).GE.3) THEN
29830 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29831 & 'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29832 & XM1,XM2,TMIN,TMAX,TMINP
29833 ENDIF
29834 IFAIL(32) = IFAIL(32)+1
29835 IREJ = 1
29836 TT = 0.D0
29837 RETURN
29838 ENDIF
29839 TMINA = MIN(TMIN,TMINP)
29840C
29841C calculation of slope (mass-dependent parametrization)
29842 IF(IDF1+IDF2.GT.0) THEN
29843C diffraction dissociation
29844 XMP12 = XM1**2+PVIRTD(1)
29845 XMP22 = XM2**2+PVIRTD(2)
29846 XMX1 = SQRT(XMP12)
29847 XMX2 = SQRT(XMP22)
29848 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29849 FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29850 SLOPE = DBLE(IDF1+IDF2)*B0PPP
29851 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29852 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29853 SLOPE = MAX(SLOPE,1.D0)
29854C
29855 XMA1 = XMX
29856 XMA2 = XMX
29857 IF(IDF1.EQ.0) THEN
29858 XMA1 = XM1
29859 ELSE IF(IDF1.EQ.0) THEN
29860 XMA2 = XM2
29861 ENDIF
29862 XMP12 = XMA1**2+PVIRTD(1)
29863 XMP22 = XMA2**2+PVIRTD(2)
29864 XMX1 = SQRT(XMP12)
29865 XMX2 = SQRT(XMP22)
29866 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29867 SLMIN = DBLE(IDF1+IDF2)*B0PPP
29868 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29869 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29870 SLMIN = MAX(SLMIN,1.D0)
29871 ELSE
29872C elastic/quasi-elastic scattering
29873 IF(ISWMDL(13).EQ.0) THEN
29874C external slope values
29875C PRINT LO,'PHO_DIFSLP:ERROR: this option is not installed !'
29876 CALL PHO_ABORT
29877 ELSE IF(ISWMDL(13).EQ.1) THEN
29878C model slopes
29879 IF(IVEC1*IVEC2.EQ.0) THEN
29880 SLOPE = SLOEL
29881 ELSE
29882 SLOPE = SLOVM(IVEC1,IVEC2)
29883 ENDIF
29884 SLMIN = SLOPE
29885 ELSE
29886 WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29887 & ISWMDL(13)
29888 CALL PHO_ABORT
29889 ENDIF
29890 ENDIF
29891C
29892C determine max. abs(t) to avoid underflows
29893 TMAXP = -25.D0/SLOPE
29894 TMAXA = MAX(TMAX,TMAXP)
29895C
29896 IF(TMINA.LT.TMAXA) THEN
29897 IF(IDEB(44).GE.3) THEN
29898 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29899 & 'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29900 & XM1,XM2,TMINA,TMAXA,SLOPE
29901 ENDIF
29902 IFAIL(32) = IFAIL(32)+1
29903 IREJ = 1
29904 TT = 0.D0
29905 RETURN
29906 ENDIF
29907C
29908C sampling from corrected range of T
29909 TMINE = EXP(SLMIN*TMINA)
29910 TMAXE = EXP(SLMIN*TMAXA)
29911 XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29912 TT = LOG(XI)/SLMIN
29913 SLWGHT = EXP((SLOPE-SLMIN)*TT)
29914C
29915C debug output
29916 IF(IDEB(44).GE.15) THEN
29917 WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29918 & 'PHO_DIFSLP: sampled momentum transfer:',TT,
29919 & 'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29920 & 'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29921 ENDIF
29922 END
29923
29924*$ CREATE PHO_DIFKIN.FOR
29925*COPY PHO_DIFKIN
29926CDECK ID>, PHO_DIFKIN
29927 SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29928C**********************************************************************
29929C
29930C calculation of diffractive kinematics
29931C
29932C input: XMP1 mass of outgoing particle system 1 (GeV)
29933C XMP2 mass of outgoing particle system 2 (GeV)
29934C TT momentum transfer (GeV**2, negative)
29935C
29936C output: PMOM1(5) four momentum of outgoing system 1
29937C PMOM2(5) four momentum of outgoing system 2
29938C IREJ 0 kinematics consistent
29939C 1 kinematics inconsistent
29940C
29941C**********************************************************************
29942 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29943 SAVE
29944
29945 PARAMETER(EPS = 1.D-10,
29946 & DEPS = 0.001)
29947
29948C input/output channels
29949 INTEGER LI,LO
29950 COMMON /POINOU/ LI,LO
29951C event debugging information
29952 INTEGER NMAXD
29953 PARAMETER (NMAXD=100)
29954 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29955 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29956 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29957 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29958C c.m. kinematics of diffraction
29959 INTEGER NPOSD
29960 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29961 & SIDD,CODD,SIFD,COFD,PDCMS
29962 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29963 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29964C some constants
29965 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29966 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29967 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29968
29969 DOUBLE PRECISION PMOM1,PMOM2
29970 DIMENSION PMOM1(5),PMOM2(5)
29971
29972C debug output
29973 IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29974 & 'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29975 & ECMD,PCMD,XMP1,XMP2,TT
29976
29977C general kinematic constraints
29978 IREJ = 1
29979 IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29980
29981C new squared cms momentum
29982 XMP12 = XMP1**2
29983 XMP22 = XMP2**2
29984 SS = ECMD**2
29985 PCM2 = PCMD**2
29986 PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29987
29988C new longitudinal/transverse momentum
29989 E1I = SQRT(PCM2+PMASSD(1)**2)
29990 E1F = SQRT(PCMP2+XMP12)
29991 E2F = SQRT(PCMP2+XMP22)
29992 PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29993 PTRAN = PCMP2-PLONG**2
29994
29995C check consistency of kinematics
29996 IF(PTRAN.LT.0.D0) THEN
29997 IF(IDEB(49).GE.1) THEN
29998 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29999 & 'inconsistent kinematics in event call: ',KEVENT
30000 WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
30001 & 'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
30002 & XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
30003 ENDIF
30004 IREJ = 1
30005 RETURN
30006 ELSE
30007 PTRAN = SQRT(PTRAN)
30008 ENDIF
30009 XI = PI2*DT_RNDM(PTRAN)
30010
30011C outgoing momenta in cm. system
30012 PMOM1(4) = E1F
30013 PMOM1(1) = PTRAN*COS(XI)
30014 PMOM1(2) = PTRAN*SIN(XI)
30015 PMOM1(3) = PLONG
30016 PMOM1(5) = XMP1
30017
30018 PMOM2(4) = E2F
30019 PMOM2(1) = -PMOM1(1)
30020 PMOM2(2) = -PMOM1(2)
30021 PMOM2(3) = -PLONG
30022 PMOM2(5) = XMP2
30023 IREJ = 0
30024
30025C debug output / precision check
30026 IF(IDEB(49).GE.0) THEN
30027C check kinematics
30028 XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
30029 & -PMOM1(1)**2-PMOM1(2)**2
30030 XM1 = SIGN(SQRT(ABS(XM1)),XM1)
30031 XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
30032 & -PMOM2(1)**2-PMOM2(2)**2
30033 XM2 = SIGN(SQRT(ABS(XM2)),XM2)
30034 IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
30035 WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
30036 & 'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
30037 & XMP1,XM1,XMP2,XM2
30038 CALL PHO_PREVNT(-1)
30039 ENDIF
30040C output
30041 IF(IDEB(49).GT.10) THEN
30042 WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
30043 & 'PHO_DIFKIN: P1',PMOM1,' P2',PMOM2
30044 ENDIF
30045 ENDIF
30046
30047 END
30048
30049*$ CREATE PHO_VECRES.FOR
30050*COPY PHO_VECRES
30051CDECK ID>, PHO_VECRES
30052 SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
30053C**********************************************************************
30054C
30055C sampling of vector meson resonance in diffractive processes
30056C (nothing done for hadrons)
30057C
30058C input: /POSVDM/ VDMFAC factors
30059C
30060C output: IVEC 0 incoming hadron
30061C 1 rho 0
30062C 2 omega
30063C 3 phi
30064C 4 pi+/pi- background
30065C RMASS mass of vector meson (GeV)
30066C IDPDG particle ID according to PDG
30067C IDBAM particle ID according to CPC
30068C
30069C**********************************************************************
30070 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30071 SAVE
30072
30073 PARAMETER(EPS = 1.D-10)
30074
30075C input/output channels
30076 INTEGER LI,LO
30077 COMMON /POINOU/ LI,LO
30078C event debugging information
30079 INTEGER NMAXD
30080 PARAMETER (NMAXD=100)
30081 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30082 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30083 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30084 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30085C nucleon-nucleus / nucleus-nucleus interface to DPMJET
30086 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30087 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30088 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30089 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30090C parameters of the "simple" Vector Dominance Model
30091 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
30092 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
30093C some constants
30094 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30095 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30096 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30097
30098C particle code translation
30099 DIMENSION ITRANS(4)
30100C rho0,omega,phi,pi+/pi-
30101 DATA ITRANS /113, 223, 333, 92 /
30102
30103 IDPDO = IDPDG
30104C
30105C vector meson production
30106 IF(IDPDG.EQ.22) THEN
30107 XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
30108 SUM = 0.D0
30109 DO 55 K=1,4
30110 SUM = SUM + VMFA(K)
30111 IF(XI.LE.SUM) GOTO 65
30112 55 CONTINUE
30113 65 CONTINUE
30114C
30115 IDPDG = ITRANS(K)
30116 IDBAM = ipho_pdg2id(IDPDG)
30117 IVEC = K
30118C sample mass of vector meson
30119 CALL PHO_SAMASS(IDPDG,RMASS)
30120
30121C hadronic resonance of multi-pomeron coupling
30122 ELSE IF(IDPDG.EQ.990) THEN
30123 K = 4
30124 IDPDG = 91
30125 IDBAM = ipho_pdg2id(IDPDG)
30126 IVEC = 4
30127C sample mass of two-pion system
30128 CALL PHO_SAMASS(IDPDG,RMASS)
30129
30130C hadron remnants in inucleus interactions
30131 ELSE IF(IDPDG.EQ.81) THEN
30132 IF(IHFLD(1,1).EQ.0) THEN
30133 CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
30134 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
30135 ELSE
30136 CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
30137 ENDIF
30138 RMAS1 = PHO_PMASS(IDBA1,0)
30139 RMAS2 = PHO_PMASS(IDBA2,0)
30140 IF((IDBA2.NE.0).AND.
30141 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
30142 IDBAM = IDBA2
30143 RMASS = RMAS2
30144 ELSE
30145 IDBAM = IDBA1
30146 RMASS = RMAS1
30147 ENDIF
30148 IDPDG = IPHO_ID2PDG(IDBAM)
30149 IVEC = 0
30150 ELSE IF(IDPDG.EQ.82) THEN
30151 IF(IHFLD(2,1).EQ.0) THEN
30152 CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
30153 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
30154 ELSE
30155 CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
30156 ENDIF
30157 RMAS1 = PHO_PMASS(IDBA1,0)
30158 RMAS2 = PHO_PMASS(IDBA2,0)
30159 IF((IDBA2.NE.0).AND.
30160 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
30161 IDBAM = IDBA2
30162 RMASS = RMAS2
30163 ELSE
30164 IDBAM = IDBA1
30165 RMASS = RMAS1
30166 ENDIF
30167 IDPDG = IPHO_ID2PDG(IDBAM)
30168 IVEC = 0
30169 ENDIF
30170C debug output
30171 IF(IDEB(47).GE.5) THEN
30172 WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
30173 & 'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
30174 & IDPDO,IDPDG,IDBAM,RMASS
30175 ENDIF
30176
30177 END
30178
30179*$ CREATE PHO_DIFRES.FOR
30180*COPY PHO_DIFRES
30181CDECK ID>, PHO_DIFRES
30182 SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
30183 & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
30184C**********************************************************************
30185C
30186C list of resonance states for low mass resonances
30187C
30188C input: IDMOTH PDG ID of mother particle
30189C IVAL1,2 quarks (photon only)
30190C
30191C output: IDPDG list of PDG IDs for possible resonances
30192C IDBAM list of corresponding CPC IDs
30193C RMASS mass
30194C RGAMS decay width
30195C RMASS additional weight factor
30196C LISTL entries in current list
30197C
30198C**********************************************************************
30199 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30200 SAVE
30201
30202 DIMENSION IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
30203
30204 PARAMETER (EPS = 1.D-10,
30205 & DEPS = 1.D-15)
30206
30207C input/output channels
30208 INTEGER LI,LO
30209 COMMON /POINOU/ LI,LO
30210C event debugging information
30211 INTEGER NMAXD
30212 PARAMETER (NMAXD=100)
30213 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30214 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30215 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30216 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30217C particle ID translation table
30218 integer ID_pdg_list,ID_list,ID_pdg_max
30219 character*12 name_list
30220 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
30221 & ID_pdg_max
30222C general particle data
30223 double precision xm_list,tau_list,gam_list,
30224 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30225 & xm_bb82_list,xm_bb102_list
30226 integer ich3_list,iba3_list,iq_list,
30227 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
30228 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30229 & xm_psm2_list(6,6),xm_vem2_list(6,6),
30230 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30231 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30232 & ich3_list(300),iba3_list(300),iq_list(3,300),
30233 & id_psm_list(6,6),id_vem_list(6,6),
30234 & id_b8_list(6,6,6),id_b10_list(6,6,6)
30235
30236 DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
30237 DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
30238 & 12212, 42212, -12212, -42212,
30239 & 8*0 /
30240 DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
30241 & 1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
30242 & 8*1.D0 /
30243
30244 DATA init /0/
30245
30246C initialize table
30247 if(init.eq.0) then
30248 do i=1,20
30249 if(IRPDG(i).ne.0) then
30250 IRBAM(i) = ipho_pdg2id(IRPDG(i))
30251 endif
30252 enddo
30253 init = 1
30254 endif
30255
30256C copy table with particles and isospin weights
30257 LISTL = 0
30258 IF(IDMOTH.EQ.22) THEN
30259 I1 = 4
30260 I2 = 8
30261 ELSE IF(IDMOTH.EQ.2212) THEN
30262 I1 = 9
30263 I2 = 10
30264 ELSE IF(IDMOTH.EQ.-2212) THEN
30265 I1 = 11
30266 I2 = 12
30267 ELSE
30268 RETURN
30269 ENDIF
30270
30271 DO 100 I=I1,I2
30272 LISTL = LISTL+1
30273 IDBAM(LISTL) = IRBAM(I)
30274 IDPDG(LISTL) = IRPDG(I)
30275 RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
30276 RGAM(LISTL) = gam_list(iabs(IDBAM(LISTL)))
30277 RWG(LISTL) = RWGHT(I)
30278 100 CONTINUE
30279
30280C debug output
30281 IF(IDEB(85).GE.20) THEN
30282 WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
30283 & IVAL1,IVAL2
30284 DO 200 I=1,LISTL
30285 WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
30286 200 CONTINUE
30287 ENDIF
30288
30289 END
30290
30291*$ CREATE PHO_MASSAD.FOR
30292*COPY PHO_MASSAD
30293CDECK ID>, PHO_MASSAD
30294 SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30295 & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30296C***********************************************************************
30297C
30298C fine-correction of low mass strings to mass of corresponding
30299C resonance or two particle threshold
30300C
30301C input: IFLMO PDG ID of mother particle
30302C IFL1,2 requested parton flavours
30303C (not used at the moment)
30304C PMASS reference mass (mass of mother particle)
30305C XMCON conjecture of mass
30306C
30307C output: XMOUT output mass (adjusted input mass)
30308C moved ot nearest mass possible
30309C IDPDG PDG resonance ID
30310C IDcpc CPC resonance ID
30311C
30312C**********************************************************************
30313 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30314 SAVE
30315
30316 PARAMETER ( DEPS = 1.D-8 )
30317
30318C input/output channels
30319 INTEGER LI,LO
30320 COMMON /POINOU/ LI,LO
30321C event debugging information
30322 INTEGER NMAXD
30323 PARAMETER (NMAXD=100)
30324 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30325 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30326 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30327 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30328C model switches and parameters
30329 CHARACTER*8 MDLNA
30330 INTEGER ISWMDL,IPAMDL
30331 DOUBLE PRECISION PARMDL
30332 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30333C general particle data
30334 double precision xm_list,tau_list,gam_list,
30335 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30336 & xm_bb82_list,xm_bb102_list
30337 integer ich3_list,iba3_list,iq_list,
30338 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
30339 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30340 & xm_psm2_list(6,6),xm_vem2_list(6,6),
30341 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30342 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30343 & ich3_list(300),iba3_list(300),iq_list(3,300),
30344 & id_psm_list(6,6),id_vem_list(6,6),
30345 & id_b8_list(6,6,6),id_b10_list(6,6,6)
30346C particle decay data
30347 double precision wg_sec_list
30348 integer idec_list,isec_list
30349 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30350 & isec_list(3,500)
30351
30352 DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30353
30354 XMINP = XMCON
30355 IDPDG = 0
30356 IDcpc = 0
30357 XMOUT = XMINP
30358
30359C resonance treatment activated?
30360 IF(ISWMDL(23).EQ.0) RETURN
30361
30362 CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30363 IF(LISTL.LT.1) THEN
30364 IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30365 & 'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30366 & IFLMO,IFL1,IFL2
30367 GOTO 50
30368 ENDIF
30369C mass small?
30370 PMASSL = (PMASS+0.15D0)**2
30371 XMINP2 = XMINP**2
30372C determine resonance probability
30373 DM2 = 1.1D0
30374 RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30375 IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30376C sample new resonance
30377 XWGSUM = 0.D0
30378 DO 100 I=1,LISTL
30379 XWG(I) = RWG(I)/RMA(I)**2
30380 XWGSUM = XWGSUM+XWG(I)
30381 100 CONTINUE
30382
30383 ITER = 0
30384 150 CONTINUE
30385 ITER = ITER+1
30386 IF(ITER.GE.5) THEN
30387 IDcpc = 0
30388 IDPDG = 0
30389 XMOUT = XMINP
30390 GOTO 50
30391 ENDIF
30392
30393 I = 0
30394 XI = XWGSUM*DT_RNDM(XMOUT)
30395 200 CONTINUE
30396 I = I+1
30397 XWGSUM = XWGSUM-XWG(I)
30398 IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30399 IDPDG = IRPDG(I)
30400 IDcpc = IRBAM(I)
30401 GARES = RGA(I)
30402 XMRES = RMA(I)
30403 XMRES2 = XMRES**2
30404C sample new mass (from Breit-Wigner cross section)
30405 ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30406 AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30407 XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30408 XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30409 XMOUT = SQRT(XMOUT)
30410
30411C check mass for decay
30412 AMDCY = 2.D0*XMRES
30413 ID = abs(IDcpc)
30414 DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30415 AMSUM = 0.D0
30416 DO 275 I=1,3
30417 IF(isec_list(I,IK).NE.0)
30418 & AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30419 275 CONTINUE
30420 AMDCY = MIN(AMDCY,AMSUM)
30421 250 CONTINUE
30422 IF(AMDCY.GE.XMOUT) GOTO 150
30423
30424C debug output
30425 IF(IDEB(7).GE.10)
30426 & WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30427 & 'PHO_MASSAD: ',
30428 & 'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30429 & IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30430 RETURN
30431 ENDIF
30432
30433 50 CONTINUE
30434C debug output
30435 IF(IDEB(7).GE.15)
30436 & WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30437 & 'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30438 & IFLMO,IFL1,IFL2,XMCON,XMOUT
30439
30440 END
30441
30442*$ CREATE PHO_PDF.FOR
30443*COPY PHO_PDF
30444CDECK ID>, PHO_PDF
30445 SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30446C***************************************************************
30447C
30448C call different PDF sets for different particle types
30449C
30450C input: NPAR 1 IGRP(1),ISET(1)
30451C 2 IGRP(2),ISET(2)
30452C X momentum fraction
30453C SCALE2 squared scale (GeV**2)
30454C P2VIR particle virtuality (positive, GeV**2)
30455C
30456C output PD(-6:6) field containing the x*PDF fractions
30457C
30458C***************************************************************
30459 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30460 SAVE
30461
30462 DIMENSION PD(-6:6)
30463
30464C input/output channels
30465 INTEGER LI,LO
30466 COMMON /POINOU/ LI,LO
30467C currently activated parton density parametrizations
30468 CHARACTER*8 PDFNAM
30469 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30470 DOUBLE PRECISION PDFLAM,PDFQ2M
30471 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30472 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30473C event debugging information
30474 INTEGER NMAXD
30475 PARAMETER (NMAXD=100)
30476 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30477 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30478 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30479 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30480C model switches and parameters
30481 CHARACTER*8 MDLNA
30482 INTEGER ISWMDL,IPAMDL
30483 DOUBLE PRECISION PARMDL
30484 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30485
30486 DIMENSION PARAM(20),VALUE(20)
30487 CHARACTER*20 PARAM
30488
30489 REAL XR,P2R,Q2R,F2GM,XPDFGM
30490 DIMENSION XPDFGM(-6:6)
30491
30492C check of kinematic boundaries
30493 XI = X
30494 IF(X.GT.1.D0) THEN
30495 IF(IDEB(37).GE.0) THEN
30496 WRITE(LO,'(/,1X,A,E15.8/)')
30497 & 'PHO_PDF: x>1 (corrected to x=1)',X
30498 CALL PHO_PREVNT(-1)
30499 ENDIF
30500 XI = 0.99999999999D0
30501 ELSE IF(X.LE.0.D0) THEN
30502 IF(IDEB(37).GE.0) THEN
30503 WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30504 CALL PHO_PREVNT(-1)
30505 ENDIF
30506 XI = 0.0001D0
30507 ENDIF
30508
30509 DO 100 I=-6,6
30510 PD(I) = 0.D0
30511 100 CONTINUE
30512 IRET = 1
30513
30514 IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30515
30516C internal PDFs
30517
30518 IF(IEXT(NPAR).EQ.0) THEN
30519 IF(ITYPE(NPAR).EQ.1) THEN
30520C proton PDFs
30521 IF(IGRP(NPAR).EQ.5) THEN
30522 IF(ISET(NPAR).EQ.3) THEN
30523 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30524 UV = UDV-DV
30525 UDB = 2.D0*UDB
30526 DEL = 0.D0
30527 IRET = 0
30528 ELSE IF(ISET(NPAR).EQ.4) THEN
30529 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30530 UV = UDV-DV
30531 UDB = 2.D0*UDB
30532 DEL = 0.D0
30533 IRET = 0
30534 ELSE IF(ISET(NPAR).EQ.5) THEN
30535 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30536C heavy quarks from GRV92-HO
30537 AMU2 = 0.3
30538 ALAM2 = 0.248 * 0.248
30539 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30540 SC = 0.820
30541 ALC = 0.98
30542 BEC = 0.0
30543 AKC = -0.625 - 0.523 * S
30544 AGC = 0.0
30545 BC = 1.896 + 1.616 * S
30546 DC = 4.12 + 0.683 * S
30547 EC = 4.36 + 1.328 * S
30548 ESC = 0.677 + 0.679 * S
30549 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30550 SBO = 1.297
30551 ALB = 0.99
30552 BEB = 0.0
30553 AKB = 0.0 - 0.193 * S
30554 AGB = 0.0
30555 BBO = 0.0
30556 DB = 3.447 + 0.927 * S
30557 EB = 4.68 + 1.259 * S
30558 ESB = 1.892 + 2.199 * S
30559 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30560 IRET = 0
30561 ELSE IF(ISET(NPAR).EQ.6) THEN
30562 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30563C heavy quarks from GRV92-LO
30564 AMU2 = 0.25
30565 ALAM2 = 0.232D0**2
30566 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30567 SC = 0.888
30568 ALC = 1.01
30569 BEC = 0.37
30570 AKC = 0.0
30571 AGC = 0.0
30572 BC = 4.24 - 0.804 * S
30573 DC = 3.46 + 1.076 * S
30574 EC = 4.61 + 1.490 * S
30575 ESC = 2.555 + 1.961 * S
30576 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30577 SBO = 1.351
30578 ALB = 1.00
30579 BEB = 0.51
30580 AKB = 0.0
30581 AGB = 0.0
30582 BBO = 1.848
30583 DB = 2.929 + 1.396 * S
30584 EB = 4.71 + 1.514 * S
30585 ESB = 4.02 + 1.239 * S
30586 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30587 IRET = 0
30588 ELSE IF(ISET(NPAR).EQ.7) THEN
30589 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30590C heavy quarks from GRV92-HO
30591 AMU2 = 0.3
30592 ALAM2 = 0.248 * 0.248
30593 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30594 SC = 0.820
30595 ALC = 0.98
30596 BEC = 0.0
30597 AKC = -0.625 - 0.523 * S
30598 AGC = 0.0
30599 BC = 1.896 + 1.616 * S
30600 DC = 4.12 + 0.683 * S
30601 EC = 4.36 + 1.328 * S
30602 ESC = 0.677 + 0.679 * S
30603 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30604 SBO = 1.297
30605 ALB = 0.99
30606 BEB = 0.0
30607 AKB = 0.0 - 0.193 * S
30608 AGB = 0.0
30609 BBO = 0.0
30610 DB = 3.447 + 0.927 * S
30611 EB = 4.68 + 1.259 * S
30612 ESB = 1.892 + 2.199 * S
30613 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30614 IRET = 0
30615 ELSE IF(ISET(NPAR).EQ.8) THEN
30616 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30617 DEL = DS-US
30618 UDB = DS+US
30619C heavy quarks from GRV92-LO
30620 AMU2 = 0.25
30621 ALAM2 = 0.232D0**2
30622 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30623 SC = 0.888
30624 ALC = 1.01
30625 BEC = 0.37
30626 AKC = 0.0
30627 AGC = 0.0
30628 BC = 4.24 - 0.804 * S
30629 DC = 3.46 + 1.076 * S
30630 EC = 4.61 + 1.490 * S
30631 ESC = 2.555 + 1.961 * S
30632 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30633 SBO = 1.351
30634 ALB = 1.00
30635 BEB = 0.51
30636 AKB = 0.0
30637 AGB = 0.0
30638 BBO = 1.848
30639 DB = 2.929 + 1.396 * S
30640 EB = 4.71 + 1.514 * S
30641 ESB = 4.02 + 1.239 * S
30642 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30643 IRET = 0
30644 ELSE IF(ISET(NPAR).EQ.9) THEN
30645* CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30646 DEL = DS-US
30647 UDB = DS+US
30648C heavy quarks from GRV92-LO
30649 AMU2 = 0.25
30650 ALAM2 = 0.232D0**2
30651 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30652 SC = 0.888
30653 ALC = 1.01
30654 BEC = 0.37
30655 AKC = 0.0
30656 AGC = 0.0
30657 BC = 4.24 - 0.804 * S
30658 DC = 3.46 + 1.076 * S
30659 EC = 4.61 + 1.490 * S
30660 ESC = 2.555 + 1.961 * S
30661 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30662 SBO = 1.351
30663 ALB = 1.00
30664 BEB = 0.51
30665 AKB = 0.0
30666 AGB = 0.0
30667 BBO = 1.848
30668 DB = 2.929 + 1.396 * S
30669 EB = 4.71 + 1.514 * S
30670 ESB = 4.02 + 1.239 * S
30671 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30672 IRET = 0
30673 ENDIF
30674 PD(-5) = BB
30675 PD(-4) = CB
30676 PD(-3) = SB
30677 PD(-2) = 0.5D0*(UDB-DEL)
30678 PD(-1) = 0.5D0*(UDB+DEL)
30679 PD(0) = GL
30680 PD(1) = DV+PD(-1)
30681 PD(2) = UV+PD(-2)
30682 PD(3) = PD(-3)
30683 PD(4) = PD(-4)
30684 PD(5) = PD(-5)
30685 ENDIF
30686 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30687C pion PDFs (default for pi+)
30688 IF(IGRP(NPAR).EQ.5) THEN
30689 IF(ISET(NPAR).EQ.1) THEN
30690 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30691 IRET = 0
30692 ELSE IF(ISET(NPAR).EQ.2) THEN
30693 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30694 IRET = 0
30695 ENDIF
30696 PD(-5) = BB
30697 PD(-4) = CB
30698 PD(-3) = QB
30699 PD(-2) = QB
30700 PD(-1) = QB+VA
30701 PD(0) = GL
30702 PD(1) = QB
30703 PD(2) = VA+QB
30704 PD(3) = QB
30705 PD(4) = CB
30706 PD(5) = BB
30707 ENDIF
30708 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30709C photon PDFs
30710 IF(IGRP(NPAR).EQ.5) THEN
30711 IF(ISET(NPAR).EQ.1) THEN
30712 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30713 IRET = 0
30714 ELSE IF(ISET(NPAR).EQ.2) THEN
30715 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30716 IRET = 0
30717 ELSE IF(ISET(NPAR).EQ.3) THEN
30718 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30719 IRET = 0
30720 ENDIF
30721C reweight with Drees-Godbole factor
30722 WGX = 1.D0
30723 IF(P2VIR.GT.0.001D0) THEN
30724 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30725 & /LOG(SCALE2/PARMDL(144))
30726 WGX = MAX(WGX,0.D0)
30727 ENDIF
30728 PD(-5) = BB*WGX/137.D0
30729 PD(-4) = CB*WGX/137.D0
30730 PD(-3) = SB*WGX/137.D0
30731 PD(-2) = UB*WGX/137.D0
30732 PD(-1) = DB*WGX/137.D0
30733 PD(0) = GL*WGX*WGX/137.D0
30734 PD(1) = PD(-1)
30735 PD(2) = PD(-2)
30736 PD(3) = PD(-3)
30737 PD(4) = PD(-4)
30738 PD(5) = PD(-5)
30739 ELSE IF(IGRP(NPAR).EQ.8) THEN
30740 IF(ISET(NPAR).EQ.1) THEN
30741 CALL PHO_PHGAL (XI,SCALE2,PD)
30742 IRET = 0
30743 ENDIF
30744 ENDIF
30745 ELSE IF(ITYPE(NPAR).EQ.20) THEN
30746C Pomeron PDFs
30747 MODE = IGRP(NPAR)
30748 IF(MODE.EQ.1) THEN
30749 PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30750 IRET = 0
30751 ELSE IF(MODE.EQ.2) THEN
30752 PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30753 IRET = 0
30754 ELSE IF(MODE.EQ.3) THEN
30755 PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30756 IRET = 0
30757 ELSE IF(MODE.EQ.4) THEN
30758 CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30759 DO 105 I=-4,4
30760 PD(I) = PD(I)*PARMDL(78)
30761 105 CONTINUE
30762 IRET = 0
30763 ENDIF
30764 ENDIF
30765
30766C external PDFs
30767
30768 ELSE IF(IEXT(NPAR).EQ.2) THEN
30769C PDFLIB call: new PDF numbering
30770 IF(NPAR.NE.NPAOLD) THEN
30771 PARAM(1) = 'NPTYPE'
30772 PARAM(2) = 'NGROUP'
30773 PARAM(3) = 'NSET'
30774 PARAM(4) = ' '
30775 VALUE(1) = ITYPE(NPAR)
30776 VALUE(2) = ABS(IGRP(NPAR))
30777 VALUE(3) = ISET(NPAR)
30778 CALL PDFSET(PARAM,VALUE)
30779 ENDIF
30780 IF(ITYPE(NPAR).EQ.3) THEN
30781 IP2 = 0
30782 CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30783 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30784 ELSE
30785 SCALE = SQRT(SCALE2)
30786 CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30787 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30788 ENDIF
30789 DO 115 I=3,6
30790 PD(I) = PD(-I)
30791 115 CONTINUE
30792 IF(ITYPE(NPAR).EQ.1) THEN
30793C proton valence quarks
30794 PD(1) = PD(1)+PD(-1)
30795 PD(2) = PD(2)+PD(-2)
30796 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30797C pi+ valences
30798 DVAL = PD(1)
30799 PD(1) = PD(-1)
30800 PD(-1) = DVAL+PD(1)
30801 PD(2) = PD(2)+PD(-2)
30802 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30803C photon conventions
30804 PD(1) = PD(-1)
30805 PD(2) = PD(-2)
30806 ENDIF
30807 IRET = 0
30808
30809 ELSE IF(IEXT(NPAR).EQ.3) THEN
30810C PHOLIB call: version 2.0
30811 CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30812 IF(IRET.LT.0) THEN
30813 WRITE(LO,'(/1X,A,I2)')
30814 & 'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30815 CALL PHO_ABORT
30816 ENDIF
30817 IRET = 0
30818
30819C photon PDFs depending on photon virtuality
30820
30821 ELSE IF(IEXT(NPAR).EQ.4) THEN
30822 IF(IGRP(NPAR).EQ.1) THEN
30823C Schuler/Sjostrand PDF (interface to single precision)
30824 XR = XI
30825 Q2R = SCALE2
30826 P2R = P2VIR
30827 IP2 = 0
30828 CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30829 DO 120 I=-6,6
30830 PD(I) = DBLE(XPDFGM(I))
30831 120 CONTINUE
30832 IRET = 0
30833 ELSE IF(IGRP(NPAR).EQ.5) THEN
30834C Gluck/Reya/Stratmann
30835 IF(ISET(NPAR).EQ.4) THEN
30836 CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30837 CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30838 IRET = 0
30839 PD(-5) = 0.D0
30840 PD(-4) = CB
30841 PD(-3) = SB/137.D0
30842 PD(-2) = UB/137.D0
30843 PD(-1) = DB/137.D0
30844 PD(0) = GL/137.D0
30845 PD(1) = PD(-1)
30846 PD(1) = PD(-1)
30847 PD(2) = PD(-2)
30848 PD(3) = PD(-3)
30849 PD(4) = PD(-4)
30850 PD(5) = PD(-5)
30851 ENDIF
30852 ENDIF
30853 ENDIF
30854
30855C check for errors
30856
30857 IF(IRET.NE.0) THEN
30858 WRITE(LO,'(/1X,A,/10X,5I6)')
30859 & 'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30860 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30861 CALL PHO_ABORT
30862 ENDIF
30863C error in NPAR
30864 ELSE
30865 WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30866 CALL PHO_ABORT
30867 ENDIF
30868 NPAOLD = NPAR
30869
30870C valence quark treatment
30871
30872 IF(ITYPE(NPAR).EQ.2) THEN
30873C meson conventions
30874 IF(IPARID(NPAR).EQ.111) THEN
30875C pi0 valence quarks
30876 PD(-1) = (PD(1)+PD(-1))/2.D0
30877 PD(1) = PD(-1)
30878 PD(-2) = (PD(2)+PD(-2))/2.D0
30879 PD(2) = PD(-2)
30880 ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30881C K+/-
30882 VALS = PD(-1)-PD(1)
30883 PD(-1) = PD(1)
30884 PD(-3) = PD(-3)+VALS
30885 ELSE IF( (IPARID(NPAR).EQ.311)
30886 & .OR.(IPARID(NPAR).EQ.310)
30887 & .OR.(IPARID(NPAR).EQ.130)) THEN
30888C neutral kaons
30889 VALS = PD(-1)-PD(1)
30890 VALU = PD(2)-PD(-2)
30891 PD(-1) = PD(1)
30892 PD(2) = PD(-2)
30893 PD(2) = PD(2)+VALU/2.D0
30894 PD(-2) = PD(-2)+VALU/2.D0
30895 PD(3) = PD(3)+VALS/2.D0
30896 PD(-3) = PD(-3)+VALS/2.D0
30897 ENDIF
30898 ELSE IF(ITYPE(NPAR).EQ.1) THEN
30899C nucleon conventions
30900 IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30901C neutron valence quarks
30902 DUM = PD(1)
30903 PD(1) = PD(2)
30904 PD(2) = DUM
30905 ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30906C (anti-)sigma+
30907 VALS = PD(1)-PD(-1)
30908 PD(1) = PD(-1)
30909 PD(3) = PD(3)+VALS
30910 ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30911C (anti-)sigma-
30912 VALS = PD(1)-PD(-1)
30913 VALD = PD(2)-PD(-2)
30914 PD(1) = PD(-1)
30915 PD(2) = PD(-2)
30916 PD(1) = PD(1)+VALD
30917 PD(3) = PD(3)+VALS
30918 ELSE IF( (ABS(IPARID(NPAR)).EQ.3122)
30919 & .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30920C (anti-)sigma0 and (anti-)lambda
30921 VALS = PD(1)-PD(-1)
30922 VALD = (PD(2)-PD(-2))/2.D0
30923 PD(1) = PD(-1)
30924 PD(2) = PD(-2)
30925 PD(1) = PD(1)+VALD
30926 PD(2) = PD(2)+VALD
30927 PD(3) = PD(3)+VALS
30928 ENDIF
30929 ENDIF
30930
30931C antiparticle
30932 IF(IPARID(NPAR).LT.0) THEN
30933 DO 190 I=1,4
30934 DUM=PD(I)
30935 PD(I)=PD(-I)
30936 PD(-I)=DUM
30937 190 CONTINUE
30938 ENDIF
30939
30940C optionally remove valence quarks
30941 IF(IPAVA(NPAR).EQ.0) THEN
30942 DO 200 I=1,4
30943 PD(I) = MIN(PD(-I),PD(I))
30944 PD(-I) = PD(I)
30945 200 CONTINUE
30946 ENDIF
30947
30948C debug information
30949 IF(IDEB(37).GE.30) WRITE(LO,
30950 & '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30951 & 'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30952 & NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30953 & 'PD(0) ',PD(0),'PD(1..6) ',(PD(I),I=1,6)
30954
30955 END
30956
30957*$ CREATE PHO_QPMPDF.FOR
30958*COPY PHO_QPMPDF
30959CDECK ID>, PHO_QPMPDF
30960 SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30961C***************************************************************
30962C
30963C contribution to photon PDF from box graph
30964C (Bethe-Heitler process)
30965C
30966C input: IQ quark flavour
30967C SCALE2 scale (GeV**2, positive)
30968C PTREF reference scale (GeV, positive)
30969C X parton momentum fraction
30970C PVIRT photon virtuality (GeV**2, positive)
30971C FXP x*f(x,Q**2), x times parton density
30972C
30973C***************************************************************
30974 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30975 SAVE
30976
30977C input/output channels
30978 INTEGER LI,LO
30979 COMMON /POINOU/ LI,LO
30980C event debugging information
30981 INTEGER NMAXD
30982 PARAMETER (NMAXD=100)
30983 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30984 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30985 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30986 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30987C internal rejection counters
30988 INTEGER NMXJ
30989 PARAMETER (NMXJ=60)
30990 CHARACTER*10 REJTIT
30991 INTEGER IFAIL
30992 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30993C some constants
30994 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30995 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30996 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30997
30998 DIMENSION QM(6)
30999 DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
31000
31001 FXP = 0.D0
31002 I = ABS(IQ)
31003C
31004* QM2 = MAX(QM(I),PTREF)**2
31005* QM2 = MAX(QM2,PVIRT)
31006* BBE = (1.D0-X)*SCALE2
31007* IF(BBE.LE.0.D0) THEN
31008* IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
31009* & 'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
31010* & PVIRT,QM(I)
31011* ENDIF
31012* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
31013* & *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
31014C Bethe-Heitler process approximation for 2*x*p2/q2 << 1
31015 QM2 = MAX(QM(I),PTREF)**2
31016 W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
31017 IF(W2.GT.4.D0*QM2) THEN
31018 BE = SQRT(1.D0-4.D0*QM2/W2)
31019 BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
31020 BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
31021* FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
31022 FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
31023 & +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
31024 & -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
31025 & +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
31026 & -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
31027 ELSE
31028 IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
31029 & 'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
31030 & PVIRT,QM(I)
31031 ENDIF
31032C debug output
31033 IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
31034 & 'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
31035 END
31036
31037*$ CREATE PHO_SETPDF.FOR
31038*COPY PHO_SETPDF
31039CDECK ID>, PHO_SETPDF
31040 SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
31041C***************************************************************
31042C
31043C assigns PDF numbers to particles
31044C
31045C input: IDPDG PDG number of particle
31046C ITYP particle type
31047C IPAR PDF paramertization
31048C ISET number of set
31049C IEXT library number for PDF calculation
31050C IPAVAL (only output)
31051C 1 PDF with valence quarks
31052C 0 PDF without valence quarks
31053C MODE -1 add entry to table
31054C 1 read from table
31055C 2 output of table
31056C
31057C***************************************************************
31058 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31059 SAVE
31060
31061C input/output channels
31062 INTEGER LI,LO
31063 COMMON /POINOU/ LI,LO
31064C event debugging information
31065 INTEGER NMAXD
31066 PARAMETER (NMAXD=100)
31067 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31068 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31069 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31070 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31071C nucleon-nucleus / nucleus-nucleus interface to DPMJET
31072 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
31073 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
31074 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
31075 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
31076
31077 DIMENSION IPDFS(5,50)
31078 DATA IENTRY / 0 /
31079
31080 IF(MODE.EQ.1) THEN
31081 I = 1
31082 IF(IDPDG.EQ.81) THEN
31083 IDCMP = IDEQP(1)
31084 IPAVAL = IHFLS(1)
31085 ELSE IF(IDPDG.EQ.82) THEN
31086 IDCMP = IDEQP(2)
31087 IPAVAL = IHFLS(2)
31088 ELSE
31089 IDCMP = IDPDG
31090 IPAVAL = 1
31091 ENDIF
31092200 CONTINUE
31093 IF(IDCMP.EQ.IPDFS(1,I)) THEN
31094 ITYP = IPDFS(2,I)
31095 IPAR = IPDFS(3,I)
31096 ISET = IPDFS(4,I)
31097 IEXT = IPDFS(5,I)
31098 IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
31099 & 'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
31100 RETURN
31101 ENDIF
31102 I = I+1
31103 IF(I.GT.IENTRY) THEN
31104 WRITE(LO,'(/1X,A,I7)')
31105 & 'PHO_SETPDF: no PDF assigned to ',IDCMP
31106 CALL PHO_ABORT
31107 ENDIF
31108 GOTO 200
31109 ELSE IF(MODE.EQ.-1) THEN
31110 DO 50 I=1,IENTRY
31111 IF(IDPDG.EQ.IPDFS(1,I)) THEN
31112 WRITE(LO,'(/1X,A,5I6)')
31113 & 'PHO_SETPDF: overwrite old particle PDF',
31114 & IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
31115 GOTO 100
31116 ENDIF
31117 50 CONTINUE
31118 I = IENTRY+1
31119 IF(I.GT.50) THEN
31120 WRITE(LO,'(/1X,A,/1x,6I6)')
31121 & 'PHO_SETPDF:ERROR: no space left in IPDFS:',
31122 & I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
31123 STOP
31124 ENDIF
31125 IENTRY = I
31126 100 CONTINUE
31127 IPDFS(1,I) = IDPDG
31128 IF(IDPDG.EQ.990) THEN
31129 ITYP1 = 20
31130 ELSE IF(IDPDG.EQ.22) THEN
31131 ITYP1 = 3
31132 ELSE IF(ABS(IDPDG).LT.1000) THEN
31133 ITYP1 = 2
31134 ELSE
31135 ITYP1 = 1
31136 ENDIF
31137 IPDFS(2,I) = ITYP1
31138 IPDFS(3,I) = IPAR
31139 IPDFS(4,I) = ISET
31140 IPDFS(5,I) = IEXT
31141 ELSE IF(MODE.EQ.-2) THEN
31142 WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
31143 DO 150 I=1,IENTRY
31144 WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,' particle:',IPDFS(1,I),
31145 & ' PDF-set ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
31146 150 CONTINUE
31147 ELSE
31148 WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
31149 ENDIF
31150 END
31151
31152*$ CREATE PHO_GETPDF.FOR
31153*COPY PHO_GETPDF
31154CDECK ID>, PHO_GETPDF
31155 SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31156C***************************************************************
31157C
31158C get PDF information
31159C
31160C input: NPAR 1 first PDF in /POPPDF/
31161C 2 second PDF in /POPPDF/
31162C
31163C output: PDFNA name of PDf parametrization
31164C ALA QCD LAMBDA (4 flavours, in GeV)
31165C Q2MI minimal Q2
31166C Q2MA maximal Q2
31167C XMI minimal X
31168C XMA maximal X
31169C
31170C***************************************************************
31171 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31172 SAVE
31173
31174 CHARACTER*8 PDFNA
31175
31176C input/output channels
31177 INTEGER LI,LO
31178 COMMON /POINOU/ LI,LO
31179
31180C PHOLIB 4.15 common
31181 COMMON /W50512/ QCDL4,QCDL5
31182 COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
31183
31184C PHOPDF version 2.0 common
31185 PARAMETER (MAXS=6,MAXP=10)
31186 CHARACTER*4 CHPAR
31187 COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
31188 & NSET(MAXP,2),NFL(MAXP)
31189 COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
31190
31191C currently activated parton density parametrizations
31192 CHARACTER*8 PDFNAM
31193 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31194 DOUBLE PRECISION PDFLAM,PDFQ2M
31195 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31196 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31197
31198 DIMENSION PARAM(20),VALUE(20)
31199 CHARACTER*20 PARAM
31200
31201 IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
31202 WRITE(LO,'(/1X,A,I6)')
31203 & 'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
31204 CALL PHO_ABORT
31205 ENDIF
31206 ALA = 0.D0
31207
31208 IF(IEXT(NPAR).EQ.0) THEN
31209
31210C internal parametrizations
31211
31212 IF(ITYPE(NPAR).EQ.1) THEN
31213C proton PDFs
31214 IF(IGRP(NPAR).EQ.5) THEN
31215 IF(ISET(NPAR).EQ.3) THEN
31216 ALA = 0.2D0
31217 Q2MI = 0.3D0
31218 PDFNA = 'GRV92 HO'
31219 ELSE IF(ISET(NPAR).EQ.4) THEN
31220 ALA = 0.2D0
31221 Q2MI = 0.25D0
31222 PDFNA = 'GRV92 LO'
31223 ELSE IF(ISET(NPAR).EQ.5) THEN
31224 ALA = 0.2D0
31225 Q2MI = 0.4D0
31226 PDFNA = 'GRV94 HO'
31227 ELSE IF(ISET(NPAR).EQ.6) THEN
31228 ALA = 0.2D0
31229 Q2MI = 0.4D0
31230 PDFNA = 'GRV94 LO'
31231 ELSE IF(ISET(NPAR).EQ.7) THEN
31232 ALA = 0.2D0
31233 Q2MI = 0.4D0
31234 PDFNA = 'GRV94 DI'
31235 ELSE IF(ISET(NPAR).EQ.8) THEN
31236 ALA = 0.175D0
31237 Q2MI = 0.8D0
31238 PDFNA = 'GRV98 LO'
31239 ELSE IF(ISET(NPAR).EQ.9) THEN
31240 ALA = 0.175D0
31241 Q2MI = 0.8D0
31242 PDFNA = 'GRV98 SC'
31243 ENDIF
31244 ENDIF
31245 ELSE IF(ITYPE(NPAR).EQ.2) THEN
31246C pion PDFs
31247 IF(IGRP(NPAR).EQ.5) THEN
31248 IF(ISET(NPAR).EQ.1) THEN
31249 ALA = 0.2D0
31250 Q2MI = 0.3D0
31251 PDFNA = 'GRV-P HO'
31252 ELSE IF(ISET(NPAR).EQ.2) THEN
31253 ALA = 0.2D0
31254 Q2MI = 0.25D0
31255 PDFNA = 'GRV-P LO'
31256 ENDIF
31257 ENDIF
31258 ELSE IF(ITYPE(NPAR).EQ.3) THEN
31259C photon PDFs
31260 IF(IGRP(NPAR).EQ.5) THEN
31261 IF(ISET(NPAR).EQ.1) THEN
31262 ALA = 0.2D0
31263 Q2MI = 0.3D0
31264 PDFNA = 'GRV-G LH'
31265 ELSE IF(ISET(NPAR).EQ.2) THEN
31266 ALA = 0.2D0
31267 Q2MI = 0.3D0
31268 PDFNA = 'GRV-G HO'
31269 ELSE IF(ISET(NPAR).EQ.3) THEN
31270 ALA = 0.2D0
31271 Q2MI = 0.25D0
31272 PDFNA = 'GRV-G LO'
31273 ENDIF
31274 ELSE IF(IGRP(NPAR).EQ.8) THEN
31275 IF(ISET(NPAR).EQ.1) THEN
31276 ALA = 0.2D0
31277 Q2MI = 4.D0
31278 PDFNA = 'AGL-G LO'
31279 ENDIF
31280 ENDIF
31281 ELSE IF(ITYPE(NPAR).EQ.20) THEN
31282C pomeron PDFs
31283 IF(IGRP(NPAR).EQ.4) THEN
31284 CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
31285 ELSE
31286 ALA = 0.3D0
31287 Q2MI = 2.D0
31288 PDFNA = 'POM-PDF1'
31289 ENDIF
31290 ENDIF
31291
31292C external parametrizations
31293
31294 ELSE IF(IEXT(NPAR).EQ.1) THEN
31295C PDFLIB call: old numbering
31296 PARAM(1) = 'MODE'
31297 PARAM(2) = ' '
31298 VALUE(1) = IGRP(NPAR)
31299 CALL PDFSET(PARAM,VALUE)
31300 Q2MI = Q2MIN
31301 Q2MA = Q2MAX
31302 XMI = XMIN
31303 XMA = XMAX
31304 ALA = QCDL4
31305 PDFNA = 'PDFLIB1'
31306 ELSE IF(IEXT(NPAR).EQ.2) THEN
31307C PDFLIB call: new numbering
31308 PARAM(1) = 'NPTYPE'
31309 PARAM(2) = 'NGROUP'
31310 PARAM(3) = 'NSET'
31311 PARAM(4) = ' '
31312 VALUE(1) = ITYPE(NPAR)
31313 VALUE(2) = IGRP(NPAR)
31314 VALUE(3) = ISET(NPAR)
31315 CALL PDFSET(PARAM,VALUE)
31316 Q2MI = Q2MIN
31317 Q2MA = Q2MAX
31318 XMI = XMIN
31319 XMA = XMAX
31320 ALA = QCDL4
31321 PDFNA = 'PDFLIB2'
31322 ELSE IF(IEXT(NPAR).EQ.3) THEN
31323C PHOLIB interface
31324 ALA = ALM(IGRP(NPAR),ISET(NPAR))
31325 Q2MI = 2.D0
31326 PDFNA = CHPAR(IGRP(NPAR))
31327
31328C some special internal parametrizations
31329
31330 ELSE IF(IEXT(NPAR).EQ.4) THEN
31331C photon PDFs depending on virtualities
31332 IF(IGRP(NPAR).EQ.1) THEN
31333C Schuler/Sjostrand parametrization
31334 ALA = 0.2D0
31335 IF(ISET(NPAR).EQ.1) THEN
31336 Q2MI = 0.2D0
31337 PDFNA = 'SaS-1D '
31338 ELSE IF(ISET(NPAR).EQ.2) THEN
31339 Q2MI = 0.2D0
31340 PDFNA = 'SaS-1M '
31341 ELSE IF(ISET(NPAR).EQ.3) THEN
31342 Q2MI = 2.D0
31343 PDFNA = 'SaS-2D '
31344 ELSE IF(ISET(NPAR).EQ.4) THEN
31345 Q2MI = 2.D0
31346 PDFNA = 'SaS-2M '
31347 ENDIF
31348 ELSE IF(IGRP(NPAR).EQ.5) THEN
31349C Gluck/Reya/Stratmann parametrization
31350 IF(ISET(NPAR).EQ.4) THEN
31351 ALA = 0.2D0
31352 Q2MI = 0.6D0
31353 PDFNA = 'GRS-G LO'
31354 ENDIF
31355 ENDIF
31356 ELSE IF(IEXT(NPAR).EQ.5) THEN
31357C Schuler/Sjostrand anomalous only
31358 ALA = 0.2D0
31359 Q2MI = 0.2D0
31360 PDFNA = 'SaS anom'
31361 ENDIF
31362 IF(ALA.LT.0.01D0) THEN
31363 WRITE(LO,'(/1X,2A,/10X,5I6)')
31364 & 'PHO_GETPDF:ERROR: ',
31365 & 'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31366 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31367 CALL PHO_ABORT
31368 ENDIF
31369
31370 END
31371
31372*$ CREATE PHO_ACTPDF.FOR
31373*COPY PHO_ACTPDF
31374CDECK ID>, PHO_ACTPDF
31375 SUBROUTINE PHO_ACTPDF(IDPDG,K)
31376C***************************************************************
31377C
31378C activate PDF for QCD calculations
31379C
31380C input: IDPDG PDG particle number
31381C K 1 first PDF in /POPPDF/
31382C 2 second PDF in /POPPDF/
31383C -2 write current settings
31384C
31385C output: /POPPDF/
31386C
31387C***************************************************************
31388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31389 SAVE
31390
31391C input/output channels
31392 INTEGER LI,LO
31393 COMMON /POINOU/ LI,LO
31394C event debugging information
31395 INTEGER NMAXD
31396 PARAMETER (NMAXD=100)
31397 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31398 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31399 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31400 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31401C currently activated parton density parametrizations
31402 CHARACTER*8 PDFNAM
31403 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31404 DOUBLE PRECISION PDFLAM,PDFQ2M
31405 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31406 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31407
31408 IF(K.GT.0) THEN
31409
31410C read PDF from table
31411 CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31412 & IPAVA(K),1)
31413 IPARID(K) = IDPDG
31414C get PDF parameters
31415 CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31416C initialize alpha_s calculation
31417 alam2 = PDFLAM(K)*PDFLAM(K)
31418 DUMMY = PHO_ALPHAS(alam2,-K)
31419
31420 IF(IDEB(2).GE.20) THEN
31421 WRITE(LO,'(1X,A)')
31422 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31423 WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31424 & PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31425 & IEXT(K),IPARID(K)
31426 ENDIF
31427 NPAOLD = K
31428
31429 ELSE IF(K.EQ.-2) THEN
31430
31431C write table of current PDFs
31432 WRITE(LO,'(1X,A)')
31433 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31434 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31435 & PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31436 & IPARID(1)
31437 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31438 & PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31439 & IPARID(2)
31440
31441 ELSE
31442
31443 WRITE(LO,'(/1X,A,2I4)')
31444 & 'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31445 CALL PHO_ABORT
31446
31447 ENDIF
31448
31449 END
31450
31451*$ CREATE PHO_PDFTST.FOR
31452*COPY PHO_PDFTST
31453CDECK ID>, PHO_PDFTST
31454 SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31455C*********************************************************************
31456C
31457C structure function test utility
31458C
31459C input: IDPDG PDG ID of particle
31460C SCALE2 squared scale (GeV**2)
31461C P2MASS particle virtuality (pos, GeV**2)
31462C
31463C output: tables of PDF, sum rule checking, table of F2
31464C
31465C*********************************************************************
31466 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31467 SAVE
31468
31469C input/output channels
31470 INTEGER LI,LO
31471 COMMON /POINOU/ LI,LO
31472C currently activated parton density parametrizations
31473 CHARACTER*8 PDFNAM
31474 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31475 DOUBLE PRECISION PDFLAM,PDFQ2M
31476 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31477 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31478C some constants
31479 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31480 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31481 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31482
31483 DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31484 CHARACTER*8 PDFNA
31485
31486 CALL PHO_ACTPDF(IDPDG,1)
31487 CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31488
31489 WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31490 WRITE(LO,'(A)') ' ======================================='
31491
31492 WRITE(LO,'(/,A,3I10)')
31493 & ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31494 WRITE(LO,'(A,A)') ' corresponds to ',PDFNA
31495 WRITE(LO,'(A,E12.3)') ' used squared scale (GeV**2):',SCALE2
31496 WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31497 WRITE(LO,'(/1X,A)') 'x times parton densities'
31498 WRITE(LO,'(1X,A)') ' X PD(-4 - 4)'
31499 WRITE(LO,'(1X,A)')
31500 & ' ============================================================'
31501
31502C logarithmic loop over x values
31503C upper bound
31504 XUPPER=0.9999D0
31505C lower bound
31506 XLOWER=1.D-4
31507C number of steps
31508 NSTEP=50
31509
31510 XFIRST=LOG(XLOWER)
31511 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31512 DO 100 I=1,NSTEP
31513 X=EXP(XFIRST)
31514 XCONTR=X
31515 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31516 IF(X.NE.XCONTR) THEN
31517 WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31518 ENDIF
31519 WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31520 XFIRST=XFIRST+XDELTA
31521 100 CONTINUE
31522
31523 IF(IDPDG.EQ.22) THEN
31524 WRITE(LO,'(/1X,A)')
31525 & 'comparison PDF to contribution due to box diagram'
31526 WRITE(LO,'(1X,A)') ' X PD(1),PB(1), .... ,PD(4),PB(4)'
31527 WRITE(LO,'(1X,A)')
31528 & ' ============================================================'
31529 XFIRST=LOG(XLOWER)
31530 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31531 DO 110 I=1,NSTEP
31532 X=EXP(XFIRST)
31533 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31534 DO 120 K=1,4
31535 CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31536 120 CONTINUE
31537 WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31538 XFIRST=XFIRST+XDELTA
31539 110 CONTINUE
31540 ENDIF
31541
31542C check momentum sum rule
31543
31544 WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31545 DO 199 I=-6,6
31546 PDSUM(I) = 0.D0
31547 PDAVE(I) = 0.D0
31548 199 CONTINUE
31549 ITER=5000
31550 DO 200 I=1,ITER
31551 XX=DBLE(I)/DBLE(ITER)
31552 IF(XX.EQ.1.D0) XX = 0.999999D0
31553 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31554 DO 202 K=-6,6
31555 PDSUM(K) = PDSUM(K)+PD(K)/XX
31556 PDAVE(K) = PDAVE(K)+PD(K)
31557 202 CONTINUE
31558 200 CONTINUE
31559 WRITE(LO,'(1X,A)')
31560 & 'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31561 XSUM = 0.D0
31562 DO 204 I=-6,6
31563 PDSUM(I) = PDSUM(I)/DBLE(ITER)
31564 PDAVE(I) = PDAVE(I)/DBLE(ITER)
31565 XSUM = XSUM+PDAVE(I)
31566 WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31567 204 CONTINUE
31568 WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31569 DO 205 I=1,6
31570 WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31571 205 CONTINUE
31572 WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31573 WRITE(LO,'(A/)') ' ============================================='
31574
31575C table of F2
31576
31577 WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31578 & 'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31579 & '-----------------------------------------------------'
31580 ITER=100
31581 DO 300 I=1,ITER
31582 XX=DBLE(I)/DBLE(ITER)
31583 IF(XX.EQ.1.D0) XX = 0.9999D0
31584 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31585 F2 = 0.D0
31586 DO 302 K=-6,6
31587 IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31588 302 CONTINUE
31589 WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31590 300 CONTINUE
31591 WRITE(LO,'(A/)') ' ============================================='
31592 END
31593
31594*$ CREATE PHO_REGPAR.FOR
31595*COPY PHO_REGPAR
31596CDECK ID>, PHO_REGPAR
31597 SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31598 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31599C**********************************************************************
31600C
31601C registration of particle in /POEVT1/ and /POEVT2/
31602C
31603C input: ISTH status code of particle
31604C -2 initial parton hard scattering
31605C -1 parton
31606C 0 string
31607C 1 visible particle (no color)
31608C 2 decayed particle
31609C IDPDG PDG particle ID code
31610C IDBAM CPC particle ID code
31611C JM1,JM2 first and second mother index
31612C P1..P4 four momentum
31613C IPHIS1 extended history information
31614C IPHIS1<100: JM1 from particle 1
31615C IPHIS1>100: JM1 from particle 2
31616C 1 valence quark
31617C 2 valence diquark
31618C 3 sea quark
31619C 4 sea diquark
31620C (neg. for antipartons)
31621C IPHIS2 extended history information
31622C positive: JM2 from particle 1
31623C negative: JM2 from particle 2
31624C (see IPHIS1)
31625C IC1,IC2 color labels for partons
31626C IMODE 1 register given parton
31627C 0 reset /POEVT1/ and /POEVT2/
31628C 2 return data of entry IPOS
31629C
31630C IPOS position of particle in /POEVT1/
31631C
31632C**********************************************************************
31633 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31634 SAVE
31635
31636 PARAMETER (DEPS = 1.D-20)
31637
31638C input/output channels
31639 INTEGER LI,LO
31640 COMMON /POINOU/ LI,LO
31641C event debugging information
31642 INTEGER NMAXD
31643 PARAMETER (NMAXD=100)
31644 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31645 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31646 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31647 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31648
31649C standard particle data interface
31650 INTEGER NMXHEP
31651
31652 PARAMETER (NMXHEP=4000)
31653
31654 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31655 DOUBLE PRECISION PHEP,VHEP
31656 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31657 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31658 & VHEP(4,NMXHEP)
31659C extension to standard particle data interface (PHOJET specific)
31660 INTEGER IMPART,IPHIST,ICOLOR
31661 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31662
31663 IF(IMODE.EQ.1) THEN
31664 IF(IDEB(76).GE.26) THEN
31665 WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31666 & 'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31667 & ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31668 WRITE(LO,'(1X,A,/2X,6I6)')
31669 & 'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31670 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31671 ENDIF
31672 IF(NHEP.EQ.NMXHEP) THEN
31673 WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31674 & 'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31675 CALL PHO_ABORT
31676 ENDIF
31677 NHEP = NHEP+1
31678 IDBAMI = IDBAM
31679 IDPDGI = IDPDG
31680 IF(ABS(ISTH).LE.2) THEN
31681 IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31682 IDPDGI = ipho_id2pdg(IDBAM)
31683 ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31684 IDBAMI = ipho_pdg2id(IDPDG)
31685 ENDIF
31686 ENDIF
31687C standard data
31688 ISTHEP(NHEP) = ISTH
31689 IDHEP(NHEP) = IDPDGI
31690 JMOHEP(1,NHEP) = JM1
31691 JMOHEP(2,NHEP) = JM2
31692C update of mother-daugther relations
31693 IF(ABS(ISTH).LE.1) THEN
31694 IF(JM1.GT.0) THEN
31695 IF(JDAHEP(1,JM1).EQ.0) THEN
31696 JDAHEP(1,JM1) = NHEP
31697 ISTHEP(JM1) = 2
31698 ENDIF
31699 JDAHEP(2,JM1) = NHEP
31700 ENDIF
31701 IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31702 IF(JDAHEP(1,JM2).EQ.0) THEN
31703 JDAHEP(1,JM2) = NHEP
31704 ISTHEP(JM2) = 2
31705 ENDIF
31706 JDAHEP(2,JM2) = NHEP
31707 ELSE IF(JM2.LT.0) THEN
31708 DO 100 II=JM1+1,-JM2
31709 IF(JDAHEP(1,II).EQ.0) THEN
31710 JDAHEP(1,II) = NHEP
31711 ISTHEP(II) = 2
31712 ENDIF
31713 JDAHEP(2,II) = NHEP
31714100 CONTINUE
31715 ENDIF
31716 ENDIF
31717 PHEP(1,NHEP) = P1
31718 PHEP(2,NHEP) = P2
31719 PHEP(3,NHEP) = P3
31720 PHEP(4,NHEP) = P4
31721 IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31722 TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31723 PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31724 ELSE
31725 PHEP(5,NHEP) = 0.D0
31726 ENDIF
31727 JDAHEP(1,NHEP) = 0
31728 JDAHEP(2,NHEP) = 0
31729C extended information
31730 IMPART(NHEP) = IDBAMI
31731C extended history information
31732 IPHIST(1,NHEP) = IPHIS1
31733 IPHIST(2,NHEP) = IPHIS2
31734C charge/baryon number or color labels
31735 IF(ISTH.EQ.1) THEN
31736 ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31737 ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31738 ELSE
31739 ICOLOR(1,NHEP) = IC1
31740 ICOLOR(2,NHEP) = IC2
31741 ENDIF
31742
31743 IPOS = NHEP
31744 IF(IDEB(76).GE.26) THEN
31745 WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31746 & 'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31747 & IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31748 & PHEP(5,NHEP),IPOS
31749 ENDIF
31750
31751 ELSE IF(IMODE.EQ.0) THEN
31752 NHEP = 0
31753 ELSE IF(IMODE.EQ.2) THEN
31754 IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31755 WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31756 & 'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31757 RETURN
31758 ENDIF
31759 ISTH = ISTHEP(IPOS)
31760 IDPDG = IDHEP(IPOS)
31761 IDBAM = IMPART(IPOS)
31762 JM1 = JMOHEP(1,IPOS)
31763 JM2 = JMOHEP(2,IPOS)
31764 P1 = PHEP(1,IPOS)
31765 P2 = PHEP(2,IPOS)
31766 P3 = PHEP(3,IPOS)
31767 P4 = PHEP(4,IPOS)
31768 IPHIS1= IPHIST(1,IPOS)
31769 IPHIS2= IPHIST(2,IPOS)
31770 IC1 = ICOLOR(1,IPOS)
31771 IC2 = ICOLOR(2,IPOS)
31772 ELSE
31773 WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31774 ENDIF
31775 END
31776
31777*$ CREATE IPHO_CNV1.FOR
31778*COPY IPHO_CNV1
31779CDECK ID>, IPHO_CNV1
31780 INTEGER FUNCTION IPHO_CNV1(IPART)
31781C*********************************************************************
31782C
31783C conversion of quark numbering scheme to PARTICLE DATA GROUP
31784C convention
31785C
31786C input: old internal particle code of hard scattering
31787C 0 gluon
31788C 1 d
31789C 2 u
31790C 3 s
31791C 4 c
31792C valence quarks changed to standard numbering
31793C
31794C output: standard particle codes
31795C
31796C*********************************************************************
31797 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31798 SAVE
31799C
31800 II = ABS(IPART)
31801C change gluon number
31802 IF(II.EQ.0) THEN
31803 IPHO_CNV1 = 21
31804C change valence quark
31805 ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31806 IPHO_CNV1 = SIGN(II-6,IPART)
31807 ELSE
31808 IPHO_CNV1 = IPART
31809 ENDIF
31810 END
31811
31812*$ CREATE PHO_HACODE.FOR
31813*COPY PHO_HACODE
31814CDECK ID>, PHO_HACODE
31815 SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31816C*********************************************************************
31817C
31818C determination of hadron index from quarks
31819C
31820C input: ID1,ID2 parton code according to PDG conventions
31821C
31822C output: IDcpc1,2 CPC particle codes
31823C
31824C*********************************************************************
31825
31826 IMPLICIT NONE
31827
31828 SAVE
31829
31830 integer ID1,ID2,IDcpc1,IDcpc2
31831
31832C input/output channels
31833 INTEGER LI,LO
31834 COMMON /POINOU/ LI,LO
31835C event debugging information
31836 INTEGER NMAXD
31837 PARAMETER (NMAXD=100)
31838 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31839 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31840 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31841 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31842C general particle data
31843 double precision xm_list,tau_list,gam_list,
31844 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31845 & xm_bb82_list,xm_bb102_list
31846 integer ich3_list,iba3_list,iq_list,
31847 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
31848 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31849 & xm_psm2_list(6,6),xm_vem2_list(6,6),
31850 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31851 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31852 & ich3_list(300),iba3_list(300),iq_list(3,300),
31853 & id_psm_list(6,6),id_vem_list(6,6),
31854 & id_b8_list(6,6,6),id_b10_list(6,6,6)
31855
31856C local variables
31857 integer ii,jj,kk,i1,i2
31858
31859 IDcpc1 = 0
31860 IDcpc2 = 0
31861
31862 if(ID1*ID2.lt.0) then
31863C meson
31864 if(ID1.gt.0) then
31865 ii = ID1
31866 jj = -ID2
31867 else
31868 ii = ID2
31869 jj = -ID1
31870 endif
31871 IDcpc1 = ID_psm_list(ii,jj)
31872 IDcpc2 = ID_vem_list(ii,jj)
31873
31874 else
31875C baryon
31876 i1 = abs(ID1)
31877 i2 = abs(ID2)
31878 if(i1.gt.6) then
31879 ii = i1/1000
31880 jj = (i1-ii*1000)/100
31881 kk = i2
31882 else
31883 ii = i1
31884 jj = i2/1000
31885 kk = (i2-jj*1000)/100
31886 endif
31887 IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31888 IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31889
31890 endif
31891
31892 END
31893
31894*$ CREATE PHO_ID2STR.FOR
31895*COPY PHO_ID2STR
31896CDECK ID>, PHO_ID2STR
31897 SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31898C*********************************************************************
31899C
31900C conversion of quark numbering scheme
31901C
31902C input: standard particle codes:
31903C ID1
31904C ID2
31905C
31906C output: NOBAM CPC string code
31907C quark codes (PDG convention):
31908C IBAM1
31909C IBAM2
31910C IBAM3
31911C IBAM4
31912C
31913C NOBAM = -1 invalid flavour combinations
31914C
31915C*********************************************************************
31916 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31917 SAVE
31918
31919C input/output channels
31920 INTEGER LI,LO
31921 COMMON /POINOU/ LI,LO
31922
31923 IDA1 = ABS(ID1)
31924 IDA2 = ABS(ID2)
31925
31926C quark-antiquark string
31927 IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31928 IF((ID1*ID2).GE.0) GOTO 100
31929 IBAM1 = ID1
31930 IBAM2 = ID2
31931 IBAM3 = 0
31932 IBAM4 = 0
31933 NOBAM = 3
31934C quark-diquark string
31935 ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31936 IF((ID1*ID2).LE.0) GOTO 100
31937 IBAM1 = ID1
31938 IBAM2 = ID2/1000
31939 IBAM3 = (ID2-IBAM2*1000)/100
31940 IBAM4 = 0
31941 NOBAM = 4
31942C diquark-quark string
31943 ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31944 IF((ID1*ID2).LE.0) GOTO 100
31945 IBAM1 = ID1/1000
31946 IBAM2 = (ID1-IBAM1*1000)/100
31947 IBAM3 = ID2
31948 IBAM4 = 0
31949 NOBAM = 6
31950C gluon-gluon string
31951 ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31952 IBAM1 = 21
31953 IBAM2 = 21
31954 IBAM3 = 0
31955 IBAM4 = 0
31956 NOBAM = 7
31957C diquark-antidiquark string
31958 ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31959 IF((ID1*ID2).GE.0) GOTO 100
31960 IBAM1 = ID1/1000
31961 IBAM2 = (ID1-IBAM1*1000)/100
31962 IBAM3 = ID2/1000
31963 IBAM4 = (ID2-IBAM3*1000)/100
31964 NOBAM = 5
31965 ENDIF
31966 RETURN
31967
31968C invalid combination
31969 100 CONTINUE
31970 WRITE(LO,'(//1X,A,2I10)')
31971 & 'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31972 CALL PHO_ABORT
31973
31974 END
31975
31976*$ CREATE PHO_MKSLTR.FOR
31977*COPY PHO_MKSLTR
31978CDECK ID>, PHO_MKSLTR
31979 SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31980C********************************************************************
31981C
31982C calculate successive Lorentz boots for arbitrary Lorentz trans.
31983C
31984C input: P1 initial 4 vector
31985C GAM(3),GAMB(3) Lorentz boost parameters
31986C
31987C output: P2 final 4 vector
31988C
31989C********************************************************************
31990 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31991 SAVE
31992
31993 DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31994
31995 P2(4) = P1(4)
31996 DO 150 I=1,3
31997 P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31998 P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
31999 150 CONTINUE
32000 END
32001
32002*$ CREATE PHO_GETLTR.FOR
32003*COPY PHO_GETLTR
32004CDECK ID>, PHO_GETLTR
32005 SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
32006C********************************************************************
32007C
32008C calculate Lorentz boots for arbitrary Lorentz transformation
32009C
32010C input: P1 initial 4 vector
32011C P2 final 4 vector
32012C
32013C output: GAM(3),GAMB(3)
32014C DELE energy deviation
32015C IREJ 0 success
32016C 1 failure
32017C
32018C********************************************************************
32019 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32020 SAVE
32021
32022 PARAMETER ( DREL = 0.001D0 )
32023
32024C input/output channels
32025 INTEGER LI,LO
32026 COMMON /POINOU/ LI,LO
32027
32028 DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
32029
32030 IREJ = 1
32031 DO 50 K=1,4
32032 PA(K) = P1(K)
32033 PP(K) = P1(K)
32034 50 CONTINUE
32035 PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
32036 DO 100 I=1,3
32037 PP(I) = P2(I)
32038 PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
32039 IF(PP(4).LE.0.D0) RETURN
32040 PP(4) = SQRT(PP(4))
32041 GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
32042 & -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
32043 GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
32044 GAMB(I) = GAMB(I)*GAM(I)
32045 DO 150 K=1,4
32046 PA(K) = PP(K)
32047 150 CONTINUE
32048 100 CONTINUE
32049 DELE = P2(4)-PP(4)
32050 IREJ = 0
32051C consistency check
32052* IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
32053* PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
32054* WRITE(LO,'(/1X,A,2E12.5)')
32055* & 'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
32056* WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
32057* WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
32058* WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
32059* WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
32060* ENDIF
32061 END
32062
32063*$ CREATE PHO_ALTRA.FOR
32064*COPY PHO_ALTRA
32065CDECK ID>, PHO_ALTRA
32066 SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
32067C*********************************************************************
32068C
32069C arbitrary Lorentz transformation
32070C
32071C*********************************************************************
32072 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32073 SAVE
32074
32075 EP=PCX*BGX+PCY*BGY+PCZ*BGZ
32076 PE=EP/(GA+1.D0)+EC
32077 PX=PCX+BGX*PE
32078 PY=PCY+BGY*PE
32079 PZ=PCZ+BGZ*PE
32080 P=SQRT(PX*PX+PY*PY+PZ*PZ)
32081 E=GA*EC+EP
32082
32083 END
32084
32085*$ CREATE PHO_LTRANS.FOR
32086*COPY PHO_LTRANS
32087CDECK ID>, PHO_LTRANS
32088 SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
32089 & PL,CXL,CYL,CZL,EL)
32090C**********************************************************************
32091C
32092C Lorentz transformation into lab - system
32093C
32094C**********************************************************************
32095 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32096 SAVE
32097
32098 PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
32099
32100C input/output channels
32101 INTEGER LI,LO
32102 COMMON /POINOU/ LI,LO
32103
32104 SID=SQRT(1.D0-COD*COD)
32105 PLX=P*SID*COF
32106 PLY=P*SID*SIF
32107 PCMZ=P*COD
32108 PLZ=GAM*PCMZ+BGAM*ECM
32109 PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
32110 EL=GAM*ECM+BGAM*PCMZ
32111
32112C rotation into the original direction
32113 COZ=PLZ/PL
32114 SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
32115
32116* CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
32117
32118 AX=ABS(CX)
32119 AY=ABS(CY)
32120 IF(AX.LT.AY) THEN
32121 AMAX=AY
32122 AMIN=AX
32123 ELSE
32124 AMAX=AX
32125 AMIN=AY
32126 ENDIF
32127 IF (ABS(CX)-TINY) 1,1,2
32128 1 IF (ABS(CY)-TINY) 3,3,2
32129
32130 3 CONTINUE
32131* WRITE(LO,*)' PHO_DTRANS CX CY CZ =',CX,CY,CZ
32132 CXL=SIZ*COF
32133 CYL=SIZ*SIF
32134 CZL=COZ*CZ
32135* WRITE(LO,*)' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
32136* WRITE(LO,*) CXL,CYL,CZL
32137 RETURN
32138
32139 2 CONTINUE
32140 IF(AMAX.GT.TINY2) THEN
32141 AR=AMIN/AMAX
32142 AR=AR*AR
32143 A=AMAX*SQRT(1.D0+AR)
32144 ELSE
32145* WRITE(LO,*)' PHO_DTRANS AMAX LE TINY2 '
32146 GOTO 3
32147 ENDIF
32148 XI=SIZ*COF
32149 YI=SIZ*SIF
32150 ZI=COZ
32151 CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
32152 CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
32153 CZL=A*YI+CZ*ZI
32154
32155 END
32156
32157*$ CREATE PHO_TRANS.FOR
32158*COPY PHO_TRANS
32159CDECK ID>, PHO_TRANS
32160 SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
32161C**********************************************************************
32162C
32163C rotation of coordinate frame (1) de rotation around y axis
32164C (2) fe rotation around z axis
32165C (inverse rotation to PHO_TRANI)
32166C
32167C**********************************************************************
32168 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32169 SAVE
32170
32171 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
32172 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
32173 Z=-SDE *XO +CDE *ZO
32174
32175 END
32176
32177*$ CREATE PHO_TRANI.FOR
32178*COPY PHO_TRANI
32179CDECK ID>, PHO_TRANI
32180 SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
32181C**********************************************************************
32182C
32183C rotation of coordinate frame (1) -fe rotation around z axis
32184C (2) -de rotation around y axis
32185C (inverse rotation to PHO_TRANS)
32186C
32187C**********************************************************************
32188 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32189 SAVE
32190
32191 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
32192 Y=-SFE *XO+CFE* YO
32193 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
32194
32195 END
32196
32197*$ CREATE pho_cpcini.FOR
32198*COPY pho_cpcini
32199CDECK ID>, pho_cpcini
32200 SUBROUTINE pho_cpcini(Nrows,Number,List)
32201C***********************************************************************
32202C
32203C initialization of particle hash table
32204C
32205C input: Number vector with Nrows entries according to PDG
32206C convention
32207C
32208C output: List vector with hash table
32209C
32210C (this code is based on the function initpns written by
32211C Gerry Lynch, LBL, January 1990)
32212C
32213C***********************************************************************
32214
32215 IMPLICIT NONE
32216
32217 SAVE
32218
32219C input/output channels
32220 INTEGER LI,LO
32221 COMMON /POINOU/ LI,LO
32222
32223 integer Number(*),List(*),Nrows
32224
32225 Integer Nin,Nout,Ip,I
32226
32227 do I = 1,577
32228 List(I) = 0
32229 enddo
32230
32231C Loop over all of the elements in the Number vector
32232
32233 Do 500 Ip = 1,Nrows
32234 Nin = Number(Ip)
32235
32236C Calculate a list number for this particle id number
32237 If(Nin.Gt.99999.or.Nin.Le.0) Then
32238 Nout = -1
32239 Else If(Nin.Le.577) Then
32240 Nout = Nin
32241 Else
32242 Nout = Mod(Nin,577)
32243 End If
32244
32245 200 continue
32246
32247 If(Nout.Lt.0) Then
32248C Count the bad entries
32249 WRITE(LO,'(1x,a,i10)')
32250 & 'pho_cpcini: invalid particle ID',Nin
32251 Go to 500
32252 End If
32253 If(List(Nout).eq.0) Then
32254 List(Nout) = Ip
32255 Else
32256 If(Nin.eq.Number(List(Nout))) Then
32257 WRITE(LO,'(1x,a,i10)')
32258 & 'pho_cpcini: double particle ID',Nin
32259 End If
32260 Nout = Nout + 5
32261 If(Nout.Gt.577) Nout = Mod(Nout, 577)
32262
32263 Go to 200
32264 End If
32265 500 Continue
32266
32267 END
32268
32269*$ CREATE ipho_pdg2id.FOR
32270*COPY ipho_pdg2id
32271CDECK ID>, ipho_pdg2id
32272 INTEGER FUNCTION ipho_pdg2id(IDpdg)
32273C**********************************************************************
32274C
32275C calculation internal particle code using the particle index i
32276C according to the PDG proposal.
32277C
32278C input: IDpdg PDG particle number
32279C output: ipho_pdg2id internal particle code
32280C (0 for invalid IDpdg)
32281C
32282C the hash algorithm is based on a program by Gerry Lynch
32283C
32284C**********************************************************************
32285
32286 IMPLICIT NONE
32287
32288 SAVE
32289
32290 integer IDpdg
32291
32292C input/output channels
32293 INTEGER LI,LO
32294 COMMON /POINOU/ LI,LO
32295C event debugging information
32296 INTEGER NMAXD
32297 PARAMETER (NMAXD=100)
32298 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32299 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32300 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32301 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32302C particle ID translation table
32303 integer ID_pdg_list,ID_list,ID_pdg_max
32304 character*12 name_list
32305 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32306 & ID_pdg_max
32307
32308 integer Nin,Nout
32309
32310 Nin = abs(IDpdg)
32311
32312 if((Nin.gt.99999).or.(Nin.eq.0)) then
32313C invalid particle number
32314 if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32315 & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
32316 ipho_pdg2id = 0
32317 return
32318 else If(Nin.le.577) then
32319C simple case
32320 Nout = Nin
32321 else
32322C use hash algorithm
32323 Nout = mod(Nin,577)
32324 endif
32325
32326 100 continue
32327
32328C particle not in table
32329 if(ID_list(Nout).Eq.0) then
32330 if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32331 & 'ipho_pdg2id: particle not in table ',IDpdg
32332 ipho_pdg2id = 0
32333 return
32334 endif
32335
32336 if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32337C particle ID found
32338 ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32339 return
32340 else
32341C increment and try again
32342 Nout = Nout + 5
32343 If(Nout.gt.577) Nout = Mod(Nout,577)
32344 goto 100
32345 endif
32346
32347 END
32348
32349*$ CREATE IPHO_ID2PDG.FOR
32350*COPY IPHO_ID2PDG
32351CDECK ID>, IPHO_ID2PDG
32352 INTEGER FUNCTION ipho_id2pdg(IDcpc)
32353C**********************************************************************
32354C
32355C conversion of internal particle code to PDG standard
32356C
32357C input: IDcpc internal particle number
32358C output: ipho_id2pdg PDG particle number
32359C (0 for invalid IDcpc)
32360C
32361C**********************************************************************
32362
32363 IMPLICIT NONE
32364
32365 SAVE
32366
32367 integer IDcpc
32368
32369C input/output channels
32370 INTEGER LI,LO
32371 COMMON /POINOU/ LI,LO
32372C event debugging information
32373 INTEGER NMAXD
32374 PARAMETER (NMAXD=100)
32375 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32376 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32377 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32378 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32379C particle ID translation table
32380 integer ID_pdg_list,ID_list,ID_pdg_max
32381 character*12 name_list
32382 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32383 & ID_pdg_max
32384
32385 integer IDabs
32386
32387 IDabs = abs(IDcpc)
32388 if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32389 ipho_id2pdg = 0
32390 return
32391 endif
32392
32393 ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32394
32395 END
32396
32397*$ CREATE IPHO_LU2PDG.FOR
32398*COPY IPHO_LU2PDG
32399CDECK ID>, IPHO_LU2PDG
32400 INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32401C**********************************************************************
32402C
32403C conversion of JETSET KF code to PDG code
32404C
32405C**********************************************************************
32406 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32407 SAVE
32408 PARAMETER (NTAB=10)
32409 DIMENSION LU2PD(2,NTAB)
32410 DATA LU2PD / 4232, 4322,
32411 & 4322, 4232,
32412 & 3212, 3122,
32413 & 3122, 3212,
32414 & 30553, 20553,
32415 & 30443, 20443,
32416 & 20443, 10443,
32417 & 10443, 0,
32418 & 511, 0,
32419 & 10551, 551 /
32420C
32421 DO 100 I=1,NTAB
32422 IF(LU2PD(1,I).EQ.LUKF) THEN
32423 IPHO_LU2PDG=LU2PD(2,I)
32424 RETURN
32425 ENDIF
32426 100 CONTINUE
32427 IPHO_LU2PDG=LUKF
32428
32429 END
32430
32431*$ CREATE IPHO_PDG2LU.FOR
32432*COPY IPHO_PDG2LU
32433CDECK ID>, IPHO_PDG2LU
32434 INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32435C**********************************************************************
32436C
32437C conversion of PDG code to JETSET code
32438C
32439C**********************************************************************
32440 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32441 SAVE
32442 PARAMETER (NTAB=8)
32443 DIMENSION LU2PD(2,NTAB)
32444 DATA LU2PD / 4232, 4322,
32445 & 4322, 4232,
32446 & 3212, 3122,
32447 & 3122, 3212,
32448 & 30553, 20553,
32449 & 30443, 20443,
32450 & 20443, 10443,
32451 & 10551, 551 /
32452C
32453 DO 100 I=1,NTAB
32454 IF(LU2PD(2,I).EQ.IPDG) THEN
32455 IPHO_PDG2LU=LU2PD(1,I)
32456 RETURN
32457 ENDIF
32458 100 CONTINUE
32459 IPHO_PDG2LU=IPDG
32460
32461 END
32462
32463*$ CREATE pho_pname.FOR
32464*COPY pho_pname
32465CDECK ID>, pho_pname
32466 CHARACTER*15 FUNCTION pho_pname(ID,mode)
32467C***********************************************************************
32468C
32469C returns particle name for given ID number
32470C
32471C input: ID particle ID number
32472C mode 0: ID treated as compressed particle code
32473C 1: ID treated as PDG number
32474C
32475C***********************************************************************
32476
32477 IMPLICIT NONE
32478
32479 SAVE
32480
32481 integer ID,mode
32482
32483C input/output channels
32484 INTEGER LI,LO
32485 COMMON /POINOU/ LI,LO
32486
32487C standard particle data interface
32488 INTEGER NMXHEP
32489
32490 PARAMETER (NMXHEP=4000)
32491
32492 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32493 DOUBLE PRECISION PHEP,VHEP
32494 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32495 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32496 & VHEP(4,NMXHEP)
32497C extension to standard particle data interface (PHOJET specific)
32498 INTEGER IMPART,IPHIST,ICOLOR
32499 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32500
32501C particle ID translation table
32502 integer ID_pdg_list,ID_list,ID_pdg_max
32503 character*12 name_list
32504 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32505 & ID_pdg_max
32506C general particle data
32507 double precision xm_list,tau_list,gam_list,
32508 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32509 & xm_bb82_list,xm_bb102_list
32510 integer ich3_list,iba3_list,iq_list,
32511 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32512 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32513 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32514 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32515 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32516 & ich3_list(300),iba3_list(300),iq_list(3,300),
32517 & id_psm_list(6,6),id_vem_list(6,6),
32518 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32519
32520C external functions
32521 integer ipho_id2pdg,ipho_pdg2id
32522
32523C local variables
32524 integer IDpdg,i,ii,k,l,ichar,i_anti
32525 character*15 name
32526
32527 pho_pname = '(?????????????)'
32528
32529 if(mode.eq.0) then
32530 i = ID
32531 IDpdg = ipho_id2pdg(ID)
32532 if(IDpdg.eq.0) return
32533 else if(mode.eq.1) then
32534 i = ipho_pdg2id(ID)
32535 if(i.eq.0) return
32536 IDpdg = ID
32537 else if(mode.eq.2) then
32538 if(ISTHEP(ID).gt.11) then
32539 if(ISTHEP(ID).eq.20) then
32540 pho_pname = 'hard ini. part.'
32541 else if(ISTHEP(ID).eq.21) then
32542 pho_pname = 'hard fin. part.'
32543 else if(ISTHEP(ID).eq.25) then
32544 pho_pname = 'hard scattering'
32545 else if(ISTHEP(ID).eq.30) then
32546 pho_pname = 'diff. diss. '
32547 else if(ISTHEP(ID).eq.35) then
32548 pho_pname = 'elastic scatt. '
32549 else if(ISTHEP(ID).eq.40) then
32550 pho_pname = 'central scatt. '
32551 endif
32552 return
32553 endif
32554 IDpdg = IDHEP(ID)
32555 i = IMPART(ID)
32556 else
32557 WRITE(LO,'(1x,a,2i4)')
32558 & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
32559 return
32560 endif
32561
32562 ii = abs(i)
32563 if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32564
32565 name = name_list(ii)
32566 ichar = ich3_list(ii)*sign(1,i)
32567 if(mod(ichar,3).ne.0) then
32568 ichar = 0
32569 else
32570 ichar = ichar/3
32571 endif
32572
32573C find position of first blank character
32574 k = 1
32575 100 continue
32576 k = k+1
32577 if(name(k:k).ne.' ') goto 100
32578
32579C append anti-particle sign
32580 if(i.lt.0) then
32581 i_anti = 0
32582 do l=1,3
32583 i_anti = i_anti+iq_list(l,ii)
32584 enddo
32585 if(iba3_list(ii).ne.0) then
32586 name(k:k) = '~'
32587 k = K+1
32588 else if(((i_anti.ne.0).and.(ichar.eq.0))
32589 & .or.(IDpdg.eq.-12)
32590 & .or.(IDpdg.eq.-14)
32591 & .or.(IDpdg.eq.-16)) then
32592 name(k:k) = '~'
32593 k = K+1
32594 endif
32595 endif
32596
32597C append charge sign
32598 if(ichar.eq.-2) then
32599 name(k:k+1) = '--'
32600 else if(ichar.eq.-1) then
32601 name(k:k) = '-'
32602 else if(ichar.eq.1) then
32603 name(k:k) = '+'
32604 else if(ichar.eq.2) then
32605 name(k:k+1) = '++'
32606 endif
32607
32608 pho_pname = name
32609
32610 END
32611
32612*$ CREATE ipho_anti.FOR
32613*COPY ipho_anti
32614CDECK ID>, ipho_anti
32615 INTEGER FUNCTION ipho_anti(ID)
32616C**********************************************************************
32617C
32618C determine antiparticle for given ID
32619C
32620C input: ID gives CPC particle number
32621C
32622C output: ipho_anti antiparticle code
32623C
32624C**********************************************************************
32625
32626 IMPLICIT NONE
32627
32628 SAVE
32629
32630 integer ID
32631
32632C input/output channels
32633 INTEGER LI,LO
32634 COMMON /POINOU/ LI,LO
32635C event debugging information
32636 INTEGER NMAXD
32637 PARAMETER (NMAXD=100)
32638 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32639 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32640 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32641 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32642C particle ID translation table
32643 integer ID_pdg_list,ID_list,ID_pdg_max
32644 character*12 name_list
32645 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32646 & ID_pdg_max
32647C general particle data
32648 double precision xm_list,tau_list,gam_list,
32649 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32650 & xm_bb82_list,xm_bb102_list
32651 integer ich3_list,iba3_list,iq_list,
32652 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32653 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32654 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32655 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32656 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32657 & ich3_list(300),iba3_list(300),iq_list(3,300),
32658 & id_psm_list(6,6),id_vem_list(6,6),
32659 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32660
32661C standard particle data interface
32662 INTEGER NMXHEP
32663
32664 PARAMETER (NMXHEP=4000)
32665
32666 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32667 DOUBLE PRECISION PHEP,VHEP
32668 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32669 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32670 & VHEP(4,NMXHEP)
32671C extension to standard particle data interface (PHOJET specific)
32672 INTEGER IMPART,IPHIST,ICOLOR
32673 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32674
32675C external functions
32676 integer ipho_id2pdg,ipho_pdg2id
32677
32678C local variables
32679 integer IDabs,IDpdg,i_anti,l
32680
32681 ipho_anti = -ID
32682 IDabs = abs(ID)
32683
32684C baryons
32685 if(iba3_list(IDabs).ne.0) return
32686
32687C charged particles
32688 if(ich3_list(IDabs).ne.0) return
32689
32690C K0_s and K0_l
32691 IDpdg = ipho_id2pdg(ID)
32692 if(IDpdg.eq.310) then
32693 ID = ipho_pdg2id(130)
32694 return
32695 else if(IDpdg.eq.130) then
32696 ID = ipho_pdg2id(310)
32697 return
32698 endif
32699
32700C neutral mesons with open strangeness, charm, or beauty
32701 i_anti = 0
32702 do l=1,3
32703 i_anti = i_anti+iq_list(l,IDabs)
32704 enddo
32705 if(i_anti.ne.0) return
32706
32707C neutrinos
32708 IDpdg = abs(IDpdg)
32709 if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32710
32711 ipho_anti = ID
32712
32713 END
32714
32715*$ CREATE ipho_chr3.FOR
32716*COPY ipho_chr3
32717CDECK ID>, ipho_chr3
32718 INTEGER FUNCTION ipho_chr3(ID,mode)
32719C**********************************************************************
32720C
32721C output of three times the electric charge
32722C
32723C input: mode
32724C 0 ID gives CPC particle number
32725C 1 ID gives PDG particle number
32726C 2 ID gives position of particle in /POEVT1/
32727C
32728C**********************************************************************
32729
32730 IMPLICIT NONE
32731
32732 SAVE
32733
32734 integer ID,mode
32735
32736C input/output channels
32737 INTEGER LI,LO
32738 COMMON /POINOU/ LI,LO
32739C event debugging information
32740 INTEGER NMAXD
32741 PARAMETER (NMAXD=100)
32742 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32743 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32744 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32745 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32746
32747C standard particle data interface
32748 INTEGER NMXHEP
32749
32750 PARAMETER (NMXHEP=4000)
32751
32752 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32753 DOUBLE PRECISION PHEP,VHEP
32754 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32755 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32756 & VHEP(4,NMXHEP)
32757C extension to standard particle data interface (PHOJET specific)
32758 INTEGER IMPART,IPHIST,ICOLOR
32759 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32760
32761C particle ID translation table
32762 integer ID_pdg_list,ID_list,ID_pdg_max
32763 character*12 name_list
32764 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32765 & ID_pdg_max
32766C general particle data
32767 double precision xm_list,tau_list,gam_list,
32768 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32769 & xm_bb82_list,xm_bb102_list
32770 integer ich3_list,iba3_list,iq_list,
32771 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32772 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32773 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32774 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32775 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32776 & ich3_list(300),iba3_list(300),iq_list(3,300),
32777 & id_psm_list(6,6),id_vem_list(6,6),
32778 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32779
32780C external functions
32781 integer ipho_pdg2id
32782
32783C local variables
32784 integer i,IDpdg
32785
32786 ipho_chr3 = 0
32787
32788 if(mode.eq.0) then
32789 i = ID
32790 else if(mode.eq.1) then
32791 i = ipho_pdg2id(ID)
32792 if(i.eq.0) return
32793 IDpdg = ID
32794 else if(mode.eq.2) then
32795 if(ISTHEP(ID).gt.11) return
32796 i = IMPART(ID)
32797 IDpdg = IDHEP(ID)
32798 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32799 ipho_chr3 = ICOLOR(1,ID)
32800 return
32801 endif
32802 else
32803 WRITE(LO,'(1x,a,2i4)')
32804 & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32805 return
32806 endif
32807
32808 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32809 WRITE(LO,'(1x,a,3i8)')
32810 & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32811 ipho_chr3 = 1.D0/dble(i)
32812 call pho_prevnt(0)
32813 return
32814 endif
32815
32816 ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32817
32818 END
32819
32820*$ CREATE ipho_bar3.FOR
32821*COPY ipho_bar3
32822CDECK ID>, ipho_bar3
32823 INTEGER FUNCTION ipho_bar3(ID,mode)
32824C**********************************************************************
32825C
32826C output of three times the baryon charge
32827C
32828C index: MODE
32829C 0 ID gives CPC particle number
32830C 1 ID gives PDG particle number
32831C 2 ID gives position of particle in /POEVT1/
32832C
32833C**********************************************************************
32834
32835 IMPLICIT NONE
32836
32837 SAVE
32838
32839 integer ID,mode
32840
32841C input/output channels
32842 INTEGER LI,LO
32843 COMMON /POINOU/ LI,LO
32844C event debugging information
32845 INTEGER NMAXD
32846 PARAMETER (NMAXD=100)
32847 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32848 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32849 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32850 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32851
32852C standard particle data interface
32853 INTEGER NMXHEP
32854
32855 PARAMETER (NMXHEP=4000)
32856
32857 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32858 DOUBLE PRECISION PHEP,VHEP
32859 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32860 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32861 & VHEP(4,NMXHEP)
32862C extension to standard particle data interface (PHOJET specific)
32863 INTEGER IMPART,IPHIST,ICOLOR
32864 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32865
32866C particle ID translation table
32867 integer ID_pdg_list,ID_list,ID_pdg_max
32868 character*12 name_list
32869 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32870 & ID_pdg_max
32871C general particle data
32872 double precision xm_list,tau_list,gam_list,
32873 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32874 & xm_bb82_list,xm_bb102_list
32875 integer ich3_list,iba3_list,iq_list,
32876 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32877 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32878 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32879 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32880 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32881 & ich3_list(300),iba3_list(300),iq_list(3,300),
32882 & id_psm_list(6,6),id_vem_list(6,6),
32883 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32884
32885C external functions
32886 integer ipho_pdg2id
32887
32888C local variables
32889 integer i,IDpdg
32890
32891 ipho_bar3 = 0
32892
32893 if(mode.eq.0) then
32894 i = ID
32895 else if(mode.eq.1) then
32896 i = ipho_pdg2id(ID)
32897 if(i.eq.0) return
32898 IDpdg = ID
32899 else if(mode.eq.2) then
32900 if(ISTHEP(ID).gt.11) return
32901 i = IMPART(ID)
32902 IDpdg = IDHEP(ID)
32903 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32904 ipho_bar3 = ICOLOR(2,ID)
32905 return
32906 endif
32907 else
32908 WRITE(LO,'(1x,a,2i4)')
32909 & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32910 return
32911 endif
32912
32913 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32914 WRITE(LO,'(1x,a,3i8)')
32915 & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32916 ipho_bar3 = 1.D0/dble(i)
32917 return
32918 endif
32919
32920 ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32921
32922 END
32923
32924*$ CREATE pho_pmass.FOR
32925*COPY pho_pmass
32926CDECK ID>, pho_pmass
32927 DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32928C***********************************************************************
32929C
32930C particle mass
32931C
32932C input: mode -1 initialization
32933C 0 ID gives CPC particle number
32934C 1 ID gives PDG particle number,
32935C (for quarks current masses are returned)
32936C 2 ID gives position of particle in /POEVT1/
32937C 3 ID gives PDG parton number,
32938C (for quarks constituent masses are returned)
32939C
32940C output: average particle mass (in GeV)
32941C
32942C***********************************************************************
32943
32944 IMPLICIT NONE
32945
32946 SAVE
32947
32948 integer ID,mode,MSTJ24
32949
32950C input/output channels
32951 INTEGER LI,LO
32952 COMMON /POINOU/ LI,LO
32953C event debugging information
32954 INTEGER NMAXD
32955 PARAMETER (NMAXD=100)
32956 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32957 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32958 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32959 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32960C model switches and parameters
32961 CHARACTER*8 MDLNA
32962 INTEGER ISWMDL,IPAMDL
32963 DOUBLE PRECISION PARMDL
32964 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32965
32966C standard particle data interface
32967 INTEGER NMXHEP
32968
32969 PARAMETER (NMXHEP=4000)
32970
32971 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32972 DOUBLE PRECISION PHEP,VHEP
32973 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32974 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32975 & VHEP(4,NMXHEP)
32976C extension to standard particle data interface (PHOJET specific)
32977 INTEGER IMPART,IPHIST,ICOLOR
32978 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32979
32980C particle ID translation table
32981 integer ID_pdg_list,ID_list,ID_pdg_max
32982 character*12 name_list
32983 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32984 & ID_pdg_max
32985C general particle data
32986 double precision xm_list,tau_list,gam_list,
32987 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32988 & xm_bb82_list,xm_bb102_list
32989 integer ich3_list,iba3_list,iq_list,
32990 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32991 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32992 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32993 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32994 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32995 & ich3_list(300),iba3_list(300),iq_list(3,300),
32996 & id_psm_list(6,6),id_vem_list(6,6),
32997 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32998
32999 INTEGER MSTU,MSTJ
33000 DOUBLE PRECISION PARU,PARJ
33001 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33002
33003C external functions
33004 integer ipho_pdg2id,ipho_id2pdg
33005
33006 DOUBLE PRECISION PYMASS
33007
33008C local variables
33009 integer i,IDpdg
33010
33011 pho_pmass = 0.D0
33012
33013 if(mode.eq.0) then
33014 i = ID
33015 else if(mode.eq.1) then
33016 i = ipho_pdg2id(ID)
33017 if(i.eq.0) return
33018 else if(mode.eq.2) then
33019 if(ISTHEP(ID).gt.11) return
33020 i = IMPART(ID)
33021 IDpdg = IDHEP(ID)
33022 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
33023 pho_pmass = PHEP(5,ID)
33024 return
33025 endif
33026 else if(mode.eq.3) then
33027 i = abs(ID)
33028 if((i.gt.0).and.(i.le.6)) then
33029 pho_pmass = PARMDL(150+i)
33030 return
33031 else
33032 i = ipho_pdg2id(ID)
33033 if(i.eq.0) return
33034 endif
33035 else if(mode.eq.-1) then
33036C initialization: take masses for quarks and di-quarks from JETSET
33037 MSTJ24 = MSTJ(24)
33038 MSTJ(24) = 0
33039 do i=1,22
33040 IDpdg = ipho_id2pdg(i)
33041
33042 xm_list(i) = PYMASS(IDpdg)
33043
33044 enddo
33045 MSTJ(24) = MSTJ24
33046 return
33047 else
33048 WRITE(LO,'(1x,a,2i4)')
33049 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
33050 return
33051 endif
33052
33053 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
33054 WRITE(LO,'(1x,a,2i8)')
33055 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
33056 pho_pmass = 1.D0/dble(i)
33057 return
33058 endif
33059
33060 pho_pmass = xm_list(iabs(i))
33061
33062 END
33063
33064*$ CREATE PHO_MEMASS.FOR
33065*COPY PHO_MEMASS
33066CDECK ID>, PHO_MEMASS
33067 SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
33068C**********************************************************************
33069C
33070C determine meson masses corresponding to the input flavours
33071C
33072C input: I,J,K quark flavours (PDG convention)
33073C
33074C output: AMPS pseudo scalar meson mass
33075C AMPS2 next possible two particle configuration
33076C (two pseudo scalar mesons)
33077C AMVE vector meson mass
33078C AMVE2 next possible two particle configuration
33079C (two vector mesons)
33080C IPS,IVE meson numbers in CPC
33081C
33082C**********************************************************************
33083
33084 IMPLICIT NONE
33085
33086 SAVE
33087
33088 integer I,J,IPS,IVE
33089 double precision AMPS,AMPS2,AMVE,AMVE2
33090
33091C input/output channels
33092 INTEGER LI,LO
33093 COMMON /POINOU/ LI,LO
33094C event debugging information
33095 INTEGER NMAXD
33096 PARAMETER (NMAXD=100)
33097 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33098 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33099 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33100 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33101C particle ID translation table
33102 integer ID_pdg_list,ID_list,ID_pdg_max
33103 character*12 name_list
33104 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
33105 & ID_pdg_max
33106C general particle data
33107 double precision xm_list,tau_list,gam_list,
33108 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
33109 & xm_bb82_list,xm_bb102_list
33110 integer ich3_list,iba3_list,iq_list,
33111 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
33112 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33113 & xm_psm2_list(6,6),xm_vem2_list(6,6),
33114 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33115 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33116 & ich3_list(300),iba3_list(300),iq_list(3,300),
33117 & id_psm_list(6,6),id_vem_list(6,6),
33118 & id_b8_list(6,6,6),id_b10_list(6,6,6)
33119
33120C local variables
33121 integer ii,jj
33122
33123 IF(I.GT.0) THEN
33124 ii = I
33125 jj = -J
33126 ELSE
33127 ii = J
33128 jj = -I
33129 ENDIF
33130
33131C particle ID's
33132 IPS = id_psm_list(ii,jj)
33133 IVE = id_vem_list(ii,jj)
33134C masses
33135 if(IPS.ne.0) then
33136 AMPS = xm_list(iabs(IPS))
33137 else
33138 AMPS = 0.D0
33139 endif
33140 if(IVE.ne.0) then
33141 AMVE = xm_list(iabs(IVE))
33142 else
33143 AMVE = 0.D0
33144 endif
33145
33146C next possible two-particle configurations (add phase space)
33147 AMPS2 = xm_psm2_list(ii,jj)*1.5D0
33148 AMVE2 = xm_vem2_list(ii,jj)*1.1D0
33149
33150 END
33151
33152*$ CREATE PHO_BAMASS.FOR
33153*COPY PHO_BAMASS
33154CDECK ID>, PHO_BAMASS
33155 SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
33156C**********************************************************************
33157C
33158C determine baryon masses corresponding to the input flavours
33159C
33160C input: I,J,K quark flavours (PDG convention)
33161C
33162C output: AM8 octett baryon mass
33163C AM82 next possible two particle configuration
33164C (octett baryon and meson)
33165C AM10 decuplett baryon mass
33166C AM102 next possible two particle configuration
33167C (decuplett baryon and meson,
33168C baryon built up from first two quarks)
33169C I8,I10 internal baryon numbers
33170C
33171C**********************************************************************
33172
33173 IMPLICIT NONE
33174
33175 SAVE
33176
33177 integer I,J,K,I8,I10
33178 double precision AM8,AM82,AM10,AM102
33179
33180C input/output channels
33181 INTEGER LI,LO
33182 COMMON /POINOU/ LI,LO
33183C event debugging information
33184 INTEGER NMAXD
33185 PARAMETER (NMAXD=100)
33186 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33187 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33188 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33189 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33190C particle ID translation table
33191 integer ID_pdg_list,ID_list,ID_pdg_max
33192 character*12 name_list
33193 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
33194 & ID_pdg_max
33195C general particle data
33196 double precision xm_list,tau_list,gam_list,
33197 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
33198 & xm_bb82_list,xm_bb102_list
33199 integer ich3_list,iba3_list,iq_list,
33200 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
33201 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33202 & xm_psm2_list(6,6),xm_vem2_list(6,6),
33203 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33204 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33205 & ich3_list(300),iba3_list(300),iq_list(3,300),
33206 & id_psm_list(6,6),id_vem_list(6,6),
33207 & id_b8_list(6,6,6),id_b10_list(6,6,6)
33208
33209C local variables
33210 integer ii,jj,kk
33211
33212C find particle ID's
33213 ii = iabs(I)
33214 jj = iabs(J)
33215 kk = iabs(K)
33216 I8 = id_b8_list(ii,jj,kk)
33217 I10 = id_b10_list(ii,jj,kk)
33218
33219C masses (if combination possible)
33220 if(I8.ne.0) then
33221 AM8 = xm_list(I8)
33222 I8 = sign(I8,i)
33223 else
33224 AM8 = 0.D0
33225 endif
33226 if(I10.ne.0) then
33227 AM10 = xm_list(I10)
33228 I10 = sign(I10,i)
33229 else
33230 AM10 = 0.D0
33231 endif
33232
33233C next possible two-particle configurations (add phase space)
33234 AM82 = xm_b82_list(ii,jj,kk)*1.5D0
33235 AM102 = xm_b102_list(ii,jj,kk)*1.1D0
33236
33237 END
33238
33239*$ CREATE PHO_DQMASS.FOR
33240*COPY PHO_DQMASS
33241CDECK ID>, PHO_DQMASS
33242 SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
33243C**********************************************************************
33244C
33245C determine minimal masses corresponding to the input flavours
33246C (diquark a-diquark string system)
33247C
33248C input: I,J,K,L quark flavours (PDG convention)
33249C
33250C output: AM82 mass of two octett baryons
33251C AM102 mass of two decuplett baryons
33252C
33253C**********************************************************************
33254
33255 IMPLICIT NONE
33256
33257 SAVE
33258
33259 integer I,J,K,L
33260 double precision AM82,AM102
33261
33262C input/output channels
33263 INTEGER LI,LO
33264 COMMON /POINOU/ LI,LO
33265C event debugging information
33266 INTEGER NMAXD
33267 PARAMETER (NMAXD=100)
33268 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33269 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33270 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33271 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33272C general particle data
33273 double precision xm_list,tau_list,gam_list,
33274 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
33275 & xm_bb82_list,xm_bb102_list
33276 integer ich3_list,iba3_list,iq_list,
33277 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
33278 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33279 & xm_psm2_list(6,6),xm_vem2_list(6,6),
33280 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33281 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33282 & ich3_list(300),iba3_list(300),iq_list(3,300),
33283 & id_psm_list(6,6),id_vem_list(6,6),
33284 & id_b8_list(6,6,6),id_b10_list(6,6,6)
33285
33286C local variables
33287 integer ii,jj,kk,ll
33288
33289 ii = iabs(i)
33290 kk = iabs(k)
33291 jj = iabs(j)
33292 ll = iabs(l)
33293
33294 AM82 = xm_bb82_list(ii,jj,kk,ll)
33295 AM102 = xm_bb102_list(ii,jj,kk,ll)
33296
33297 END
33298
33299*$ CREATE PHO_CHECK.FOR
33300*COPY PHO_CHECK
33301CDECK ID>, PHO_CHECK
33302 SUBROUTINE PHO_CHECK(MD,IDEV)
33303C**********************************************************************
33304C
33305C check quantum numbers of entries in /POEVT1/ and /POEVT2/
33306C (energy, momentum, charge, baryon number conservation)
33307C
33308C input: MD -1 check overall momentum conservation
33309C and perform detailed check only in case of
33310C deviations
33311C 1 test all branchings, mother-daughter
33312C relations
33313C
33314C output: IDEV 0 no deviations
33315C 1 deviations found
33316C
33317C**********************************************************************
33318 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33319 SAVE
33320
33321C input/output channels
33322 INTEGER LI,LO
33323 COMMON /POINOU/ LI,LO
33324C event debugging information
33325 INTEGER NMAXD
33326 PARAMETER (NMAXD=100)
33327 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33328 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33329 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33330 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33331C model switches and parameters
33332 CHARACTER*8 MDLNA
33333 INTEGER ISWMDL,IPAMDL
33334 DOUBLE PRECISION PARMDL
33335 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33336C global event kinematics and particle IDs
33337 INTEGER IFPAP,IFPAB
33338 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33339 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33340C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33341 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33342 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33343 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33344 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33345
33346C standard particle data interface
33347 INTEGER NMXHEP
33348
33349 PARAMETER (NMXHEP=4000)
33350
33351 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33352 DOUBLE PRECISION PHEP,VHEP
33353 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33354 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33355 & VHEP(4,NMXHEP)
33356C extension to standard particle data interface (PHOJET specific)
33357 INTEGER IMPART,IPHIST,ICOLOR
33358 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33359
33360C color string configurations including collapsed strings and hadrons
33361 INTEGER MSTR
33362 PARAMETER (MSTR=500)
33363 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33364 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33365 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33366 & NNCH(MSTR),IBHAD(MSTR),ISTR
33367
33368C count number of errors to avoid disk overflow
33369 DATA IERR / 0 /
33370
33371 IDEV = 0
33372C conservation check suppressed
33373 IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33374
33375 IF(IPAMDL(13).GT.0) THEN
33376
33377C DPMJET call with x limitations
33378 MODE = -1
33379 ECM1 = SQRT(XPSUB*XTSUB)*ECM
33380
33381 ELSE
33382
33383C standard call
33384 MODE = MD
33385C first two entries are considered as scattering particles
33386 EE1 = PHEP(4,1) + PHEP(4,2)
33387 PX1 = PHEP(1,1) + PHEP(1,2)
33388 PY1 = PHEP(2,1) + PHEP(2,2)
33389 PZ1 = PHEP(3,1) + PHEP(3,2)
33390
33391 ENDIF
33392
33393 DDREL = PARMDL(75)
33394 DDABS = PARMDL(76)
33395 IF(MODE.EQ.-1) GOTO 500
33396
33397 50 CONTINUE
33398
33399 I = 1
33400 100 CONTINUE
33401
33402C recognize only decayed particles as mothers
33403 IF(ISTHEP(I).EQ.2) THEN
33404C search for other mother particles
33405 K = JDAHEP(1,I)
33406 IF(K.EQ.0) THEN
33407 IF(IPAMDL(178).NE.0)
33408 & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33409 & 'entry marked as decayed but no dauther given:',I
33410 GOTO 99
33411 ENDIF
33412 K1 = JMOHEP(1,K)
33413 K2 = JMOHEP(2,K)
33414C sum over mother particles
33415 ICH1 = IPHO_CHR3(K1,2)
33416 IBA1 = IPHO_BAR3(K1,2)
33417 EE1 = PHEP(4,K1)
33418 PX1 = PHEP(1,K1)
33419 PY1 = PHEP(2,K1)
33420 PZ1 = PHEP(3,K1)
33421 IF(K2.LT.0) THEN
33422 K2 = -K2
33423 IF((K1.GT.I).OR.(K2.LT.I)) THEN
33424 WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33425 & 'inconsistent mother/daughter relation found',I,K1,K2
33426 CALL PHO_PREVNT(-1)
33427 ENDIF
33428 DO 400 II=K1+1,K2
33429 IF(ABS(ISTHEP(II)).LE.2) THEN
33430 ICH1 = ICH1 + IPHO_CHR3(II,2)
33431 IBA1 = IBA1 + IPHO_BAR3(II,2)
33432 EE1 = EE1 + PHEP(4,II)
33433 PX1 = PX1 + PHEP(1,II)
33434 PY1 = PY1 + PHEP(2,II)
33435 PZ1 = PZ1 + PHEP(3,II)
33436 ENDIF
33437 400 CONTINUE
33438 ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33439 ICH1 = ICH1 + IPHO_CHR3(K2,2)
33440 IBA1 = IBA1 + IPHO_BAR3(K2,2)
33441 EE1 = EE1 + PHEP(4,K2)
33442 PX1 = PX1 + PHEP(1,K2)
33443 PY1 = PY1 + PHEP(2,K2)
33444 PZ1 = PZ1 + PHEP(3,K2)
33445 ENDIF
33446
33447C sum over daughter particles
33448 ICH2 = 0.D0
33449 IBA2 = 0.D0
33450 EE2 = 0.D0
33451 PX2 = 0.D0
33452 PY2 = 0.D0
33453 PZ2 = 0.D0
33454 DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33455 IF(ABS(ISTHEP(II)).LE.2) THEN
33456 ICH2 = ICH2 + IPHO_CHR3(II,2)
33457 IBA2 = IBA2 + IPHO_BAR3(II,2)
33458 EE2 = EE2 + PHEP(4,II)
33459 PX2 = PX2 + PHEP(1,II)
33460 PY2 = PY2 + PHEP(2,II)
33461 PZ2 = PZ2 + PHEP(3,II)
33462 ENDIF
33463 200 CONTINUE
33464
33465C conservation check
33466 ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33467 IF(ABS(EE1-EE2).GT.ESC) THEN
33468 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33469 & 'PHO_CHECK: energy conservation violated for',
33470 & 'entry,initial,final:',I,EE1,EE2
33471 IDEV = 1
33472 ENDIF
33473 ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33474 IF(ABS(PX1-PX2).GT.ESC) THEN
33475 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33476 & 'PHO_CHECK: x-momentum conservation violated for',
33477 & 'entry,initial,final:',I,PX1,PX2
33478 IDEV = 1
33479 ENDIF
33480 ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33481 IF(ABS(PY1-PY2).GT.ESC) THEN
33482 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33483 & 'PHO_CHECK: y-momentum conservation violated for',
33484 & 'entry,initial,final:',I,PY1,PY2
33485 IDEV = 1
33486 ENDIF
33487 ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33488 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33489 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33490 & 'PHO_CHECK: z-momentum conservation violated for',
33491 & 'entry,initial,final:',I,PZ1,PZ2
33492 IDEV = 1
33493 ENDIF
33494 IF(ICH1.NE.ICH2) THEN
33495 WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33496 & 'PHO_CHECK: charge conservation violated for',
33497 & 'entry,initial,final:',I,ICH1,ICH2
33498 IDEV = 1
33499 ENDIF
33500 IF(IBA1.NE.IBA2) THEN
33501 WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33502 & 'baryon charge conservation violated for',
33503 & 'entry,initial,final:',I,IBA1,IBA2
33504 IDEV = 1
33505 ENDIF
33506 IF(IDEB(20).GE.35) THEN
33507 WRITE(LO,
33508 & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33509 & 'PHO_CHECK diagnostics:',
33510 & '(1.mother/l.mother,1.daughter/l.daughter):',
33511 & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33512 & 'mother momenta ',PX1,PY1,PZ1,EE1,
33513 & 'daughter momenta ',PX2,PY2,PZ2,EE2,
33514 & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33515 ENDIF
33516 ENDIF
33517 99 CONTINUE
33518 I = I+1
33519 IF(I.LE.NHEP) GOTO 100
33520
33521 55 CONTINUE
33522
33523 IERR = IERR+IDEV
33524
33525C write complete event in case of deviations
33526 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33527 CALL PHO_PREVNT(1)
33528 IF(ISTR.GT.0) THEN
33529 CALL PHO_PRSTRG
33530
33531 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33532
33533 ENDIF
33534 ENDIF
33535
33536C stop after too many errors
33537 IF(IERR.GT.IPAMDL(179)) THEN
33538 WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33539 & 'too many inconsistencies found, program terminated',IERR
33540 CALL PHO_ABORT
33541 ENDIF
33542
33543 RETURN
33544
33545C overall check only (less time consuming)
33546
33547 500 CONTINUE
33548
33549 ICH2 = 0.D0
33550 IBA2 = 0.D0
33551 EE2 = 0.D0
33552 PX2 = 0.D0
33553 PY2 = 0.D0
33554 PZ2 = 0.D0
33555
33556 DO 300 K=3,NHEP
33557C recognize only existing particles as possible daughters
33558 IF(ABS(ISTHEP(K)).EQ.1) THEN
33559 ICH2 = ICH2 + IPHO_CHR3(K,2)
33560 IBA2 = IBA2 + IPHO_BAR3(K,2)
33561 EE2 = EE2 + PHEP(4,K)
33562 PX2 = PX2 + PHEP(1,K)
33563 PY2 = PY2 + PHEP(2,K)
33564 PZ2 = PZ2 + PHEP(3,K)
33565 ENDIF
33566 300 CONTINUE
33567
33568C check energy-momentum conservation
33569 ESC = ECM*DDREL
33570
33571 IF(IPAMDL(13).GT.0) THEN
33572
33573C DPMJET call with x limitations
33574 ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33575 IF(ABS(ECM1-ECM2).GT.ESC) THEN
33576 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33577 & 'PHO_CHECK: c.m. energy conservation violated',
33578 & 'initial/final energy:',ECM1,ECM2
33579 IDEV = 1
33580 ENDIF
33581
33582 ELSE
33583
33584C standard call
33585 IF(ABS(EE1-EE2).GT.ESC) THEN
33586 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33587 & 'PHO_CHECK: energy conservation violated',
33588 & 'initial/final energy:',EE1,EE2
33589 IDEV = 1
33590 ENDIF
33591 IF(ABS(PX1-PX2).GT.ESC) THEN
33592 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33593 & 'PHO_CHECK: x-momentum conservation violated',
33594 & 'initial/final x-momentum:',PX1,PX2
33595 IDEV = 1
33596 ENDIF
33597 IF(ABS(PY1-PY2).GT.ESC) THEN
33598 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33599 & 'PHO_CHECK: y-momentum conservation violated',
33600 & 'initial/final y-momentum:',PY1,PY2
33601 IDEV = 1
33602 ENDIF
33603 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33604 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33605 & 'PHO_CHECK: z-momentum conservation violated',
33606 & 'initial/final z-momentum:',PZ1,PZ2
33607 IDEV = 1
33608 ENDIF
33609
33610C check of quantum number conservation
33611
33612 ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33613 IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33614
33615 IF(ICH1.NE.ICH2) THEN
33616 WRITE(LO,'(1X,A,/,5X,A,2I5)')
33617 & 'PHO_CHECK: charge conservation violated',
33618 & 'initial/final charge sum',ICH1,ICH2
33619 IDEV = 1
33620 ENDIF
33621 IF(IBA1.NE.IBA2) THEN
33622 WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33623 & 'baryonic charge conservation violated',
33624 & 'initial/final baryonic charge sum',IBA1,IBA2
33625 IDEV = 1
33626 ENDIF
33627
33628 ENDIF
33629
33630C perform detailed checks in case of deviations
33631 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33632 IF(IPAMDL(13).GT.0) THEN
33633 GOTO 55
33634 ELSE
33635 DDREL = DDREL/2.D0
33636 DDABS = DDABS/2.D0
33637 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33638 & 'increasing precision of tests to',DDREL,DDABS
33639 GOTO 50
33640 ENDIF
33641 ENDIF
33642
33643 END
33644
33645*$ CREATE PHO_ABORT.FOR
33646*COPY PHO_ABORT
33647CDECK ID>, PHO_ABORT
33648 SUBROUTINE PHO_ABORT
33649C**********************************************************************
33650C
33651C top MC event generation due to fatal error,
33652C print all information of event generation and history
33653C
33654C**********************************************************************
33655 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33656 SAVE
33657
33658C input/output channels
33659 INTEGER LI,LO
33660 COMMON /POINOU/ LI,LO
33661C event debugging information
33662 INTEGER NMAXD
33663 PARAMETER (NMAXD=100)
33664 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33665 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33666 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33667 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33668C model switches and parameters
33669 CHARACTER*8 MDLNA
33670 INTEGER ISWMDL,IPAMDL
33671 DOUBLE PRECISION PARMDL
33672 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33673
33674C standard particle data interface
33675 INTEGER NMXHEP
33676
33677 PARAMETER (NMXHEP=4000)
33678
33679 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33680 DOUBLE PRECISION PHEP,VHEP
33681 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33682 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33683 & VHEP(4,NMXHEP)
33684C extension to standard particle data interface (PHOJET specific)
33685 INTEGER IMPART,IPHIST,ICOLOR
33686 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33687
33688C color string configurations including collapsed strings and hadrons
33689 INTEGER MSTR
33690 PARAMETER (MSTR=500)
33691 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33692 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33693 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33694 & NNCH(MSTR),IBHAD(MSTR),ISTR
33695C light-cone x fractions and c.m. momenta of soft cut string ends
33696 INTEGER MAXSOF
33697 PARAMETER ( MAXSOF = 50 )
33698 INTEGER IJSI2,IJSI1
33699 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33700 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33701 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33702 & IJSI1(MAXSOF),IJSI2(MAXSOF)
33703C hard scattering data
33704 INTEGER MSCAHD
33705 PARAMETER ( MSCAHD = 50 )
33706 INTEGER LSCAHD,LSC1HD,LSIDX,
33707 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33708 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33709 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33710 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33711 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33712 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33713 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33714 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33715 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33716
33717 WRITE(LO,'(//,1X,A,/,1X,A)')
33718 & 'PHO_ABORT: program execution stopped',
33719 & '===================================='
33720 WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33721C
33722 CALL PHO_SETMDL(0,0,-2)
33723 CALL PHO_PREVNT(-1)
33724 CALL PHO_ACTPDF(0,-2)
33725C print selected parton flavours
33726 WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33727 DO 700 I=1,KSOFT
33728 WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33729 700 CONTINUE
33730 WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33731 DO 750 K=1,KHARD
33732 I = LSIDX(K)
33733 WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33734 WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33735 & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33736 750 CONTINUE
33737C print selected parton momenta
33738 WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33739 DO 300 I=1,KSOFT
33740 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33741 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33742 300 CONTINUE
33743 WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33744 DO 350 K=1,KHARD
33745 I = LSIDX(K)
33746 I3 = 8*I-4
33747 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33748 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33749 350 CONTINUE
33750
33751C print /POEVT1/
33752 CALL PHO_PREVNT(0)
33753
33754C fragmentation process
33755 IF(ISTR.GT.0) THEN
33756C print /POSTRG/
33757 CALL PHO_PRSTRG
33758
33759 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33760
33761 ENDIF
33762
33763C last message
33764 WRITE(LO,'(////5X,A,///5X,A,///)')
33765 & 'PHO_ABORT: execution terminated due to fatal error',
33766 &'*** Simulating division by zero to get traceback information ***'
33767 ISTR = 100/IPAMDL(100)
33768
33769 END
33770
33771*$ CREATE PHO_TRACE.FOR
33772*COPY PHO_TRACE
33773CDECK ID>, PHO_TRACE
33774 SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33775C**********************************************************************
33776C
33777C trace program subroutines according to level,
33778C original output levels will be saved
33779C
33780C input: ISTART first event to trace
33781C ISWI number of events to trace
33782C 0 loop call, use old values
33783C -1 restore original output levels
33784C 1 store level and wait for event
33785C LEVEL desired output level
33786C 0 standard output
33787C 3 internal rejections
33788C 5 cross sections, slopes etc.
33789C 10 parameter of subroutines and
33790C results
33791C 20 huge amount of debug output
33792C 30 maximal possible output
33793C
33794C**********************************************************************
33795 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33796 SAVE
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
33809 DIMENSION IMEM(NMAXD)
33810
33811C protect ISWI
33812 ISW = ISWI
33813 10 CONTINUE
33814 IF(ISW.EQ.0) THEN
33815 IF(KEVENT.LT.ION) THEN
33816 RETURN
33817 ELSE IF(KEVENT.EQ.ION) THEN
33818 WRITE(LO,'(///,1X,A,///)')
33819 & 'PHO_TRACE: trace mode switched on'
33820 DO 100 I=1,NMAXD
33821 IMEM(I) = IDEB(I)
33822 IDEB(I) = MAX(ILEVEL,IMEM(I))
33823 100 CONTINUE
33824 ELSE IF(KEVENT.EQ.IOFF) THEN
33825 WRITE(LO,'(//,1X,A,///)')
33826 & 'PHO_TRACE: trace mode switched off'
33827 DO 200 I=1,NMAXD
33828 IDEB(I) = IMEM(I)
33829 200 CONTINUE
33830 ENDIF
33831 ELSE IF(ISW.EQ.-1) THEN
33832 DO 300 I=1,NMAXD
33833 IDEB(I) = IMEM(I)
33834 300 CONTINUE
33835 ELSE
33836C save information
33837 ION = ISTART
33838 IOFF = ISTART+ISW
33839 ILEVEL = LEVEL
33840 ENDIF
33841C check coincidence
33842 IF(ISW.GT.0) THEN
33843 ISW=0
33844 ILEVEL = LEVEL
33845 GOTO 10
33846 ENDIF
33847
33848 END
33849
33850*$ CREATE PHO_PRSTRG.FOR
33851*COPY PHO_PRSTRG
33852CDECK ID>, PHO_PRSTRG
33853 SUBROUTINE PHO_PRSTRG
33854C**********************************************************************
33855C
33856C print information of /POSTRG/
33857C
33858C**********************************************************************
33859 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33860 SAVE
33861
33862C input/output channels
33863 INTEGER LI,LO
33864 COMMON /POINOU/ LI,LO
33865C event debugging information
33866 INTEGER NMAXD
33867 PARAMETER (NMAXD=100)
33868 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33869 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33870 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33871 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33872
33873C standard particle data interface
33874 INTEGER NMXHEP
33875
33876 PARAMETER (NMXHEP=4000)
33877
33878 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33879 DOUBLE PRECISION PHEP,VHEP
33880 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33881 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33882 & VHEP(4,NMXHEP)
33883C extension to standard particle data interface (PHOJET specific)
33884 INTEGER IMPART,IPHIST,ICOLOR
33885 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33886
33887C color string configurations including collapsed strings and hadrons
33888 INTEGER MSTR
33889 PARAMETER (MSTR=500)
33890 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33891 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33892 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33893 & NNCH(MSTR),IBHAD(MSTR),ISTR
33894
33895 WRITE(LO,'(/,1X,A,I5)')
33896 & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
33897 WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33898 & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
33899 WRITE(LO,'(1X,A)')
33900 & ' ======================================================='
33901 DO 800 I=1,ISTR
33902 WRITE(LO,'(1X,9I5,1P,E11.3)')
33903 & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33904 & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33905 800 CONTINUE
33906
33907 END
33908
33909*$ CREATE PHO_PREVNT.FOR
33910*COPY PHO_PREVNT
33911CDECK ID>, PHO_PREVNT
33912 SUBROUTINE PHO_PREVNT(NPART)
33913C**********************************************************************
33914C
33915C print all information of event generation and history
33916C
33917C input: NPART -1 minimal output: process IDs
33918C 0 additional output of /POEVT1/
33919C 1 additional output of /POSTRG/
33920C 2 additional output of /HEPEVT/
33921C (call LULIST(1))
33922C
33923C**********************************************************************
33924 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33925 SAVE
33926
33927C input/output channels
33928 INTEGER LI,LO
33929 COMMON /POINOU/ LI,LO
33930C event debugging information
33931 INTEGER NMAXD
33932 PARAMETER (NMAXD=100)
33933 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33934 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33935 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33936 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33937C model switches and parameters
33938 CHARACTER*8 MDLNA
33939 INTEGER ISWMDL,IPAMDL
33940 DOUBLE PRECISION PARMDL
33941 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33942C global event kinematics and particle IDs
33943 INTEGER IFPAP,IFPAB
33944 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33945 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33946C general process information
33947 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33948 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33949
33950C standard particle data interface
33951 INTEGER NMXHEP
33952
33953 PARAMETER (NMXHEP=4000)
33954
33955 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33956 DOUBLE PRECISION PHEP,VHEP
33957 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33958 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33959 & VHEP(4,NMXHEP)
33960C extension to standard particle data interface (PHOJET specific)
33961 INTEGER IMPART,IPHIST,ICOLOR
33962 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33963
33964C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33965 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33966 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33967 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33968 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33969
33970 CHARACTER*15 PHO_PNAME
33971
33972 IF(NPART.GE.0) WRITE(LO,'(/)')
33973 WRITE(LO,'(1X,A,1PE10.3)')
33974 & 'PHO_PREVNT: c.m. energy',ECM
33975 CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33976 WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33977 & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33978 & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33979 & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33980 & KHDPO
33981 WRITE(LO,'(6X,A,I4,4I3)')
33982 & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33983 & IDIFR2,IDDPOM
33984
33985 IF(IPAMDL(13).GT.0) THEN
33986 WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33987 WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33988 & ECMN,PCMN,SECM,SPCM
33989 WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33990 ENDIF
33991
33992 IF(NPART.LT.0) RETURN
33993
33994 IF(NPART.GE.1) CALL PHO_PRSTRG
33995
33996 WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33997 ICHAS = 0
33998 IBARFS = 0
33999 IMULC = 0
34000 IMUL = 0
34001 WRITE(LO,'(/1X,A,A,/,1X,A,A)')
34002 & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
34003 & ' IH1 IH2 CO1 CO2',
34004 & '========================================================',
34005 & '===================='
34006 DO 20 IH=1,NHEP
34007 CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
34008 BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
34009 WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
34010 & IH,ISTHEP(IH),PHO_PNAME(IH,2),
34011 & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
34012 & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
34013 & ICOLOR(1,IH),ICOLOR(2,IH)
34014 IF(ABS(ISTHEP(IH)).EQ.1) THEN
34015 ICHAS = ICHAS + IPHO_CHR3(IH,2)
34016 IBARFS = IBARFS + IPHO_BAR3(IH,2)
34017 ENDIF
34018 IF(ABS(ISTHEP(IH)).EQ.1) THEN
34019 IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
34020 IMUL = IMUL+1
34021 ENDIF
34022 20 CONTINUE
34023 WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
34024 & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
34025
34026 WRITE(LO,7)
34027 PXS = 0.D0
34028 PYS = 0.D0
34029 PZS = 0.D0
34030 P0S = 0.D0
34031 DO 30 IN=1,NHEP
34032 IF( (ABS(PHEP(3,IN)).LT.99999.D0)
34033 & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
34034 WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
34035 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
34036 ELSE
34037 WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
34038 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
34039 ENDIF
34040 IF(ABS(ISTHEP(IN)).EQ.1) THEN
34041 PXS = PXS + PHEP(1,IN)
34042 PYS = PYS + PHEP(2,IN)
34043 PZS = PZS + PHEP(3,IN)
34044 P0S = P0S + PHEP(4,IN)
34045 ENDIF
34046 30 CONTINUE
34047 AMFS = P0S**2-PXS**2-PYS**2-PZS**2
34048 AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
34049 IF(P0S.LT.99999.D0) THEN
34050 WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
34051 ELSE
34052 WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
34053 ENDIF
34054 WRITE(LO,'(//)')
34055
34056 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
34057 & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
34058 & 8H CHARGE ,8H BARYON ,/)
34059 6 FORMAT(7I8,2F8.3)
34060 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
34061 & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
34062 & 2X,'-------------------------------',
34063 & '--------------------------------------------')
34064 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
34065 9 FORMAT(I10,14X,5F10.3)
34066 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
34067 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
34068 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
34069
34070 IF(NPART.GE.2) CALL PYLIST(1)
34071
34072 END
34073
34074*$ CREATE PHO_LTRHEP.FOR
34075*COPY PHO_LTRHEP
34076CDECK ID>, PHO_LTRHEP
34077 SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
34078C*******************************************************************
34079C
34080C Lorentz transformation of entries I1 to I2 in /POEVT1/
34081C
34082C********************************************************************
34083 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34084 SAVE
34085
34086 PARAMETER ( DIFF = 0.001D0,
34087 & EPS = 1.D-5 )
34088
34089C input/output channels
34090 INTEGER LI,LO
34091 COMMON /POINOU/ LI,LO
34092C event debugging information
34093 INTEGER NMAXD
34094 PARAMETER (NMAXD=100)
34095 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34096 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34097 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34098 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34099
34100C standard particle data interface
34101 INTEGER NMXHEP
34102
34103 PARAMETER (NMXHEP=4000)
34104
34105 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
34106 DOUBLE PRECISION PHEP,VHEP
34107 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
34108 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
34109 & VHEP(4,NMXHEP)
34110C extension to standard particle data interface (PHOJET specific)
34111 INTEGER IMPART,IPHIST,ICOLOR
34112 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
34113
34114 DO 100 I=I1,MIN(I2,NHEP)
34115 IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
34116 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
34117 & XX,YY,ZZ)
34118 EE=PHEP(4,I)
34119 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
34120 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
34121 ELSE IF(ISTHEP(I).EQ.20) THEN
34122 EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
34123 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
34124 & XX,YY,ZZ)
34125 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
34126 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
34127 ENDIF
34128 100 CONTINUE
34129
34130C debug precision
34131 IF(IDEB(70).LT.1) RETURN
34132 DO 200 I=I1,MIN(NHEP,I2)
34133 IF(ABS(ISTHEP(I)).GT.10) GOTO 190
34134 PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
34135 PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
34136 IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
34137 WRITE(LO,'(1X,A,I5,2E13.4)')
34138 & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
34139 ENDIF
34140 190 CONTINUE
34141 200 CONTINUE
34142
34143 END
34144
34145*$ CREATE PHO_PECMS.FOR
34146*COPY PHO_PECMS
34147CDECK ID>, PHO_PECMS
34148 SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
34149C*******************************************************************
34150C
34151C calculation of cms momentum and energy of massive particle
34152C (ID= 1 using PMASS1, 2 using PMASS2)
34153C
34154C output: PP cms momentum
34155C EE energy in CMS of particle ID
34156C
34157C********************************************************************
34158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34159 SAVE
34160
34161C input/output channels
34162 INTEGER LI,LO
34163 COMMON /POINOU/ LI,LO
34164C event debugging information
34165 INTEGER NMAXD
34166 PARAMETER (NMAXD=100)
34167 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34168 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34169 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34170 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34171C some constants
34172 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
34173 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
34174 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
34175
34176 S=ECM**2
34177 PM1 = SIGN(PMASS1**2,PMASS1)
34178 PM2 = SIGN(PMASS2**2,PMASS2)
34179 PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
34180 & + PM1**2 + PM2**2)/(2.D0*ECM)
34181
34182 IF(ID.EQ.1) THEN
34183 EE = SQRT( PM1 + PP**2 )
34184 ELSE IF(ID.EQ.2) THEN
34185 EE = SQRT( PM2 + PP**2 )
34186 ELSE
34187 WRITE(LO,'(/1X,A,I3,/)')
34188 & 'PHO_PECMS:ERROR: invalid ID number:',ID
34189 EE = PP
34190 ENDIF
34191
34192 END
34193
34194*$ CREATE PHO_FRAINI.FOR
34195*COPY PHO_FRAINI
34196CDECK ID>, PHO_FRAINI
34197 SUBROUTINE PHO_FRAINI(IDEFAU)
34198C***********************************************************************
34199C
34200C initialization of fragmentation packages
34201C (currently LUND JETSET)
34202C
34203C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
34204C changed to work in PHOJET (R.E. 1/94)
34205C
34206C input: IDEFAU 0 no hadronization at all
34207C 1 do not touch any parameter of JETSET
34208C 2 default parameters kept, decay length 10mm to
34209C define stable particles
34210C 3 load tuned parameters for JETSET 7.3
34211C neg. value: prevent strange/charm hadrons from decaying
34212C
34213C***********************************************************************
34214 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34215 SAVE
34216
34217 PARAMETER (EPS=1.D-10)
34218
34219C input/output channels
34220 INTEGER LI,LO
34221 COMMON /POINOU/ LI,LO
34222
34223 INTEGER N,NPAD,K
34224 DOUBLE PRECISION P,V
34225 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
34226
34227 INTEGER MSTU,MSTJ
34228 DOUBLE PRECISION PARU,PARJ
34229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34230
34231 INTEGER KCHG
34232 DOUBLE PRECISION PMAS,PARF,VCKM
34233 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34234
34235 INTEGER MDCY,MDME,KFDP
34236 DOUBLE PRECISION BRAT
a374771e 34237 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7b076c76 34238
34239 INTEGER PYCOMP
34240
34241 IDEFAB = ABS(IDEFAU)
34242
34243 IF(IDEFAB.EQ.0) THEN
34244 WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
34245 RETURN
34246 ENDIF
34247C defaults
34248 DEF2 = PARJ(2)
34249 IDEF12 = MSTJ(12)
34250 DEF19 = PARJ(19)
34251 DEF41 = PARJ(41)
34252 DEF42 = PARJ(42)
34253 DEF21 = PARJ(21)
34254
34255C declare stable particles
df8e16e0 34256C IF(IDEFAB.GE.2) MSTJ(22) = 2
7b076c76 34257
34258C load optimized parameters
34259 IF(IDEFAB.GE.3) THEN
34260
34261* PARJ(19)=0.19
34262C Lund a-parameter
34263C (default=0.3)
34264 PARJ(41)=0.3
34265C Lund b-parameter
34266C (default=1.0)
34267 PARJ(42)=1.0
34268C Lund sigma parameter in pt distribution
34269C (default=0.36)
34270 PARJ(21)=0.36
34271 ENDIF
34272C
34273C prevent particles decaying
34274 IF(IDEFAU.LT.0) THEN
34275C K0S
34276
34277 KC=PYCOMP(310)
34278
34279 MDCY(KC,1)=0
34280C PI0
34281
34282 KC=PYCOMP(111)
34283
34284 MDCY(KC,1)=0
34285C LAMBDA
34286
34287 KC=PYCOMP(3122)
34288
34289 MDCY(KC,1)=0
34290C ALAMBDA
34291
34292 KC=PYCOMP(-3122)
34293
34294 MDCY(KC,1)=0
34295C SIG+
34296
34297 KC=PYCOMP(3222)
34298
34299 MDCY(KC,1)=0
34300C ASIG+
34301
34302 KC=PYCOMP(-3222)
34303
34304 MDCY(KC,1)=0
34305C SIG-
34306
34307 KC=PYCOMP(3112)
34308
34309 MDCY(KC,1)=0
34310C ASIG-
34311
34312 KC=PYCOMP(-3112)
34313
34314 MDCY(KC,1)=0
34315C SIG0
34316
34317 KC=PYCOMP(3212)
34318
34319 MDCY(KC,1)=0
34320C ASIG0
34321
34322 KC=PYCOMP(-3212)
34323
34324 MDCY(KC,1)=0
34325C TET0
34326
34327 KC=PYCOMP(3322)
34328
34329 MDCY(KC,1)=0
34330C ATET0
34331
34332 KC=PYCOMP(-3322)
34333
34334 MDCY(KC,1)=0
34335C TET-
34336
34337 KC=PYCOMP(3312)
34338
34339 MDCY(KC,1)=0
34340C ATET-
34341
34342 KC=PYCOMP(-3312)
34343
34344 MDCY(KC,1)=0
34345C OMEGA-
34346
34347 KC=PYCOMP(3334)
34348
34349 MDCY(KC,1)=0
34350C AOMEGA-
34351
34352 KC=PYCOMP(-3334)
34353
34354 MDCY(KC,1)=0
34355C D+
34356
34357 KC=PYCOMP(411)
34358
34359 MDCY(KC,1)=0
34360C D-
34361
34362 KC=PYCOMP(-411)
34363
34364 MDCY(KC,1)=0
34365C D0
34366
34367 KC=PYCOMP(421)
34368
34369 MDCY(KC,1)=0
34370C A-D0
34371
34372 KC=PYCOMP(-421)
34373
34374 MDCY(KC,1)=0
34375C DS+
34376
34377 KC=PYCOMP(431)
34378
34379 MDCY(KC,1)=0
34380C A-DS+
34381
34382 KC=PYCOMP(-431)
34383
34384 MDCY(KC,1)=0
34385C ETAC
34386
34387 KC=PYCOMP(441)
34388
34389 MDCY(KC,1)=0
34390C LAMBDAC+
34391
34392 KC=PYCOMP(4122)
34393
34394 MDCY(KC,1)=0
34395C A-LAMBDAC+
34396
34397 KC=PYCOMP(-4122)
34398
34399 MDCY(KC,1)=0
34400C SIGMAC++
34401
34402 KC=PYCOMP(4222)
34403
34404 MDCY(KC,1)=0
34405C SIGMAC+
34406
34407 KC=PYCOMP(4212)
34408
34409 MDCY(KC,1)=0
34410C SIGMAC0
34411
34412 KC=PYCOMP(4112)
34413
34414 MDCY(KC,1)=0
34415C A-SIGMAC++
34416
34417 KC=PYCOMP(-4222)
34418
34419 MDCY(KC,1)=0
34420C A-SIGMAC+
34421
34422 KC=PYCOMP(-4212)
34423
34424 MDCY(KC,1)=0
34425C A-SIGMAC0
34426
34427 KC=PYCOMP(-4112)
34428
34429 MDCY(KC,1)=0
34430C KSIC+
34431
34432 KC=PYCOMP(4232)
34433
34434 MDCY(KC,1)=0
34435C KSIC0
34436
34437 KC=PYCOMP(4132)
34438
34439 MDCY(KC,1)=0
34440C A-KSIC+
34441
34442 KC=PYCOMP(-4232)
34443
34444 MDCY(KC,1)=0
34445C A-KSIC0
34446
34447 KC=PYCOMP(-4132)
34448
34449 MDCY(KC,1)=0
34450 ENDIF
34451
34452 WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34453 & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34454 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34455 & ' --------------------------------------------------',/,
34456 & 5X,'parameter description default / current',/,
34457 & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34458 & 5X,'MSTJ(12) popcorn : ',2I7,/,
34459 & 5X,'PARJ(19) popcorn : ',2F7.3,/,
34460 & 5X,'PARJ(41) Lund a : ',2F7.3,/,
34461 & 5X,'PARJ(42) Lund b : ',2F7.3,/,
34462 & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34463
34464 END
34465
34466*$ CREATE PHO_SETPAR.FOR
34467*COPY PHO_SETPAR
34468CDECK ID>, PHO_SETPAR
34469 SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34470C**********************************************************************
34471C
34472C assign a particle to either side 1 or 2
34473C (including special treatment for remnants)
34474C
34475C input: Iside 1,2 side selected for the particle
34476C -2 output of current settings
34477C IDpdg PDG number
34478C IDcpc CPC number
34479C 0 CPC determination in subroutine
34480C -1 special particle remnant, IDPDG
34481C is the particle number the remnant
34482C corresponds to (see /POHDFL/)
34483C
34484C**********************************************************************
34485
34486 IMPLICIT NONE
34487
34488 SAVE
34489
34490 integer Iside,IDpdg,IDcpc
34491 double precision Pvir
34492
34493C input/output channels
34494 INTEGER LI,LO
34495 COMMON /POINOU/ LI,LO
34496C event debugging information
34497 INTEGER NMAXD
34498 PARAMETER (NMAXD=100)
34499 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34500 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34501 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34502 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34503C global event kinematics and particle IDs
34504 INTEGER IFPAP,IFPAB
34505 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34506 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34507C nucleon-nucleus / nucleus-nucleus interface to DPMJET
34508 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34509 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34510 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34511 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34512C particle ID translation table
34513 integer ID_pdg_list,ID_list,ID_pdg_max
34514 character*12 name_list
34515 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34516 & ID_pdg_max
34517C general particle data
34518 double precision xm_list,tau_list,gam_list,
34519 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34520 & xm_bb82_list,xm_bb102_list
34521 integer ich3_list,iba3_list,iq_list,
34522 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
34523 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34524 & xm_psm2_list(6,6),xm_vem2_list(6,6),
34525 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34526 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34527 & ich3_list(300),iba3_list(300),iq_list(3,300),
34528 & id_psm_list(6,6),id_vem_list(6,6),
34529 & id_b8_list(6,6,6),id_b10_list(6,6,6)
34530C particle decay data
34531 double precision wg_sec_list
34532 integer idec_list,isec_list
34533 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34534 & isec_list(3,500)
34535
34536C external functions
34537 integer ipho_pdg2id,ipho_chr3,ipho_bar3
34538 double precision pho_pmass
34539
34540C local variables
34541 integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34542
34543 IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34544 IDcpcN = IDcpc
34545C remnant?
34546 IF(IDcpc.EQ.-1) THEN
34547 IF(Iside.EQ.1) THEN
34548 IDpdgR = 81
34549 ELSE
34550 IDpdgR = 82
34551 ENDIF
34552 IDcpcR = ipho_pdg2id(IDpdgR)
34553 IDEQB(Iside) = ipho_pdg2id(IDpdg)
34554 IDEQP(Iside) = IDpdg
34555C copy particle properties
34556 IDB = abs(IDEQB(Iside))
34557 xm_list(IDcpcR) = xm_list(IDB)
34558 tau_list(IDcpcR) = tau_list(IDB)
34559 gam_list(IDcpcR) = gam_list(IDB)
34560 IF(IHFLS(Iside).EQ.1) THEN
34561 ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34562 iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34563 ELSE
34564 ich3_list(IDcpcR) = 0
34565 iba3_list(IDcpcR) = 0
34566 ENDIF
34567C quark content
34568 IFL1 = IHFLD(Iside,1)
34569 IFL2 = IHFLD(Iside,2)
34570 IFL3 = 0
34571 IF(IHFLS(Iside).EQ.1) THEN
34572 IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34573 IFL1 = IHFLD(Iside,1)/1000
34574 IFL2 = MOD(IHFLD(Iside,1)/100,10)
34575 IFL3 = IHFLD(Iside,2)
34576 ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34577 IFL1 = IHFLD(Iside,1)
34578 IFL2 = IHFLD(Iside,2)/1000
34579 IFL3 = MOD(IHFLD(Iside,2)/100,10)
34580 ENDIF
34581 ENDIF
34582 iq_list(1,IDcpcR) = IFL1
34583 iq_list(2,IDcpcR) = IFL2
34584 iq_list(3,IDcpcR) = IFL3
34585
34586 IDcpcN = IDcpcR
34587 IDPDGN = IDPDGR
34588
34589 IF(IDEB(87).GE.5) THEN
34590 WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34591 & 'pho_setpar: remnant assignment side',Iside,
34592 & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34593 ENDIF
34594 ELSE IF(IDcpc.EQ.0) THEN
34595C ordinary hadron
34596 IHFLS(Iside) = 1
34597 IHFLD(Iside,1) = 0
34598 IHFLD(Iside,2) = 0
34599 IDcpcN = ipho_pdg2id(IDpdg)
34600 IDpdgN = IDpdg
34601 ENDIF
34602
34603C initialize /POGCMS/
34604 IFPAP(Iside) = IDpdgN
34605 IFPAB(Iside) = IDcpcN
34606 PMASS(Iside) = pho_pmass(IDcpcN,0)
34607 IF(IFPAP(Iside).EQ.22) THEN
34608 PVIRT(Iside) = ABS(PVIR)
34609 ELSE
34610 PVIRT(Iside) = 0.D0
34611 ENDIF
34612
34613 ELSE IF(Iside.EQ.-2) THEN
34614C output of current settings
34615 DO 100 I=1,2
34616 WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34617 & 'PHO_SETPAR: side',
34618 & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34619 & PVIRT(I)
34620 IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34621 WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34622 & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34623 & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34624 ENDIF
34625 100 CONTINUE
34626 ELSE
34627 WRITE(LO,'(/1X,A,I8)')
34628 & 'pho_setpar: invalid argument (Iside)',Iside
34629 ENDIF
34630
34631 END
34632
34633*$ CREATE PHO_XLAM.FOR
34634*COPY PHO_XLAM
34635CDECK ID>, PHO_XLAM
34636 DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34637C**********************************************************************
34638C
34639C auxiliary function for two/three particle decay mode
34640C (standard LAMBDA**(1/2) function)
34641C
34642C**********************************************************************
34643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34644 SAVE
34645C
34646 YZ=Y-Z
34647 XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34648 IF(XLAM.LT.0.D0) XLAM=-XLAM
34649 PHO_XLAM=SQRT(XLAM)
34650 END
34651
34652*$ CREATE PHO_BESSJ0.FOR
34653*COPY PHO_BESSJ0
34654CDECK ID>, PHO_BESSJ0
34655 DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34656C**********************************************************************
34657C
34658C CERN (KERN) LIB function C312
34659C
34660C modified by R. Engel (03/02/93)
34661C
34662C**********************************************************************
34663 DOUBLE PRECISION DX
34664 DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34665 DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34666 SAVE
34667
34668 DATA EIGHT /8.0D0/
34669 DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34670
34671 DATA C1( 0) /+0.15772 79714 7489D0/
34672 DATA C1( 1) /-0.00872 34423 5285D0/
34673 DATA C1( 2) /+0.26517 86132 0334D0/
34674 DATA C1( 3) /-0.37009 49938 7265D0/
34675 DATA C1( 4) /+0.15806 71023 3210D0/
34676 DATA C1( 5) /-0.03489 37694 1141D0/
34677 DATA C1( 6) /+0.00481 91800 6947D0/
34678 DATA C1( 7) /-0.00046 06261 6621D0/
34679 DATA C1( 8) /+0.00003 24603 2882D0/
34680 DATA C1( 9) /-0.00000 17619 4691D0/
34681 DATA C1(10) /+0.00000 00760 8164D0/
34682 DATA C1(11) /-0.00000 00026 7925D0/
34683 DATA C1(12) /+0.00000 00000 7849D0/
34684 DATA C1(13) /-0.00000 00000 0194D0/
34685 DATA C1(14) /+0.00000 00000 0004D0/
34686
34687 DATA C2( 0) /+0.99946 03493 4752D0/
34688 DATA C2( 1) /-0.00053 65220 4681D0/
34689 DATA C2( 2) /+0.00000 30751 8479D0/
34690 DATA C2( 3) /-0.00000 00517 0595D0/
34691 DATA C2( 4) /+0.00000 00016 3065D0/
34692 DATA C2( 5) /-0.00000 00000 7864D0/
34693 DATA C2( 6) /+0.00000 00000 0517D0/
34694 DATA C2( 7) /-0.00000 00000 0043D0/
34695 DATA C2( 8) /+0.00000 00000 0004D0/
34696 DATA C2( 9) /-0.00000 00000 0001D0/
34697
34698 DATA C3( 0) /-0.01555 58546 05337D0/
34699 DATA C3( 1) /+0.00006 83851 99426D0/
34700 DATA C3( 2) /-0.00000 07414 49841D0/
34701 DATA C3( 3) /+0.00000 00179 72457D0/
34702 DATA C3( 4) /-0.00000 00007 27192D0/
34703 DATA C3( 5) /+0.00000 00000 42201D0/
34704 DATA C3( 6) /-0.00000 00000 03207D0/
34705 DATA C3( 7) /+0.00000 00000 00301D0/
34706 DATA C3( 8) /-0.00000 00000 00033D0/
34707 DATA C3( 9) /+0.00000 00000 00004D0/
34708 DATA C3(10) /-0.00000 00000 00001D0/
34709
34710 X=DX
34711 V=ABS(X)
34712 IF(V .LT. EIGHT) THEN
34713 Y=V/EIGHT
34714 H=2.D0*Y**2-1.D0
34715 ALFA=-2.D0*H
34716 B1=0.D0
34717 B2=0.D0
34718 DO 1 I = 14,0,-1
34719 B0=C1(I)-ALFA*B1-B2
34720 B2=B1
34721 1 B1=B0
34722 B1=B0-H*B2
34723 ELSE
34724 R=1.D0/V
34725 Y=EIGHT*R
34726 H=2.D0*Y**2-1.D0
34727 ALFA=-2.D0*H
34728 B1=0.D0
34729 B2=0.D0
34730 DO 2 I = 9,0,-1
34731 B0=C2(I)-ALFA*B1-B2
34732 B2=B1
34733 2 B1=B0
34734 P=B0-H*B2
34735 B1=0.D0
34736 B2=0.D0
34737 DO 3 I = 10,0,-1
34738 B0=C3(I)-ALFA*B1-B2
34739 B2=B1
34740 3 B1=B0
34741 Q=Y*(B0-H*B2)
34742 B0=V-PI2
34743 B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34744 ENDIF
34745 PHO_BESSJ0=B1
34746 RETURN
34747 END
34748
34749*$ CREATE PHO_BESSI0.FOR
34750*COPY PHO_BESSI0
34751CDECK ID>, PHO_BESSI0
34752 DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34753C**********************************************************************
34754C
34755C Bessel Function I0
34756C
34757C**********************************************************************
34758 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34759 SAVE
34760
34761 AX = ABS(X)
34762 IF (AX .LT. 3.75D0) THEN
34763 Y = (X/3.75D0)**2
34764 PHO_BESSI0 =
34765 & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34766 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34767 ELSE
34768 Y = 3.75D0/AX
34769 PHO_BESSI0 =
34770 & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34771 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34772 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34773 & +Y*0.392377D-2))))))))
34774 ENDIF
34775
34776 END
34777
34778*$ CREATE PHO_BESSI1.FOR
34779*COPY PHO_BESSI1
34780CDECK ID>, PHO_BESSI1
34781 DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34782C**********************************************************************
34783C
34784C Bessel Function I1
34785C
34786C**********************************************************************
34787 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34788 SAVE
34789
34790 AX = ABS(X)
34791
34792 IF (AX .LT. 3.75D0) THEN
34793 Y = (X/3.75D0)**2
34794 BESLI1 =
34795 & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34796 & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34797 ELSE
34798 Y = 3.75D0/AX
34799 BESLI1 =
34800 & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34801 & -Y*0.420059D-2))
34802 BESLI1 =
34803 & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34804 & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34805 BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34806 ENDIF
34807 IF (X .LT. 0.D0) BESLI1 = -BESLI1
34808
34809 PHO_BESSI1 = BESLI1
34810
34811 END
34812
34813*$ CREATE PHO_BESSK0.FOR
34814*COPY PHO_BESSK0
34815CDECK ID>, PHO_BESSK0
34816 DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34817C**********************************************************************
34818C
34819C Modified Bessel Function K0
34820C
34821C**********************************************************************
34822 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34823 SAVE
34824
34825 IF (X .LT. 2.D0) THEN
34826 Y = X**2/4.D0
34827 PHO_BESSK0 =
34828 & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34829 & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34830 & +Y*(0.10750D-3+Y*0.740D-5))))))
34831 ELSE
34832 Y = 2.D0/X
34833 PHO_BESSK0 =
34834 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34835 & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34836 & +Y*(-0.251540D-2+Y*0.53208D-3))))))
34837 ENDIF
34838
34839 END
34840
34841*$ CREATE PHO_BESSK1.FOR
34842*COPY PHO_BESSK1
34843CDECK ID>, PHO_BESSK1
34844 DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34845C**********************************************************************
34846C
34847C Modified Bessel Function K1
34848C
34849C**********************************************************************
34850 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34851 SAVE
34852
34853 IF (X .LT. 2.D0) THEN
34854 Y = X**2/4.D0
34855 PHO_BESSK1 =
34856 & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34857 & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34858 & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34859 ELSE
34860 Y=2.D0/X
34861 PHO_BESSK1 =
34862 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34863 & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34864 & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34865 ENDIF
34866
34867 END
34868
34869*$ CREATE PHO_GAUSET.FOR
34870*COPY PHO_GAUSET
34871CDECK ID>, PHO_GAUSET
34872 SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34873C********************************************************************
34874C
34875C N-point gauss zeros and weights for the interval (AX,BX) are
34876C stored in arrays Z and W respectively.
34877C
34878C*********************************************************************
34879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34880 SAVE
34881
34882 COMMON /POGDAT/A(273),X(273),KTAB(96)
34883 DIMENSION Z(NX),W(NX)
34884
34885 ALPHA=0.5*(BX+AX)
34886 BETA=0.5*(BX-AX)
34887 N=NX
34888
34889C the N=1 case:
34890 IF(N.NE.1) GO TO 1
34891 Z(1)=ALPHA
34892 W(1)=BX-AX
34893 RETURN
34894
34895C the Gauss cases:
34896 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34897 IF(N.EQ.20) GO TO 2
34898 IF(N.EQ.24) GO TO 2
34899 IF(N.EQ.32) GO TO 2
34900 IF(N.EQ.40) GO TO 2
34901 IF(N.EQ.48) GO TO 2
34902 IF(N.EQ.64) GO TO 2
34903 IF(N.EQ.80) GO TO 2
34904 IF(N.EQ.96) GO TO 2
34905
34906C the extended Gauss cases:
34907 IF((N/96)*96.EQ.N) GO TO 3
34908
34909C jump to center of intervall intrgration:
34910 GO TO 100
34911
34912C get Gauss point array
34913
34914 2 CALL PHO_GAUDAT
34915C extract real points
34916 K=KTAB(N)
34917 M=N/2
34918 DO 21 J=1,M
34919C extract values from big array
34920 JTAB=K-1+J
34921 WTEMP=BETA*A(JTAB)
34922 DELTA=BETA*X(JTAB)
34923C store them backward
34924 Z(J)=ALPHA-DELTA
34925 W(J)=WTEMP
34926C store them forward
34927 JP=N+1-J
34928 Z(JP)=ALPHA+DELTA
34929 W(JP)=WTEMP
34930 21 CONTINUE
34931C store central point (odd N)
34932 IF((N-M-M).EQ.0) RETURN
34933 Z(M+1)=ALPHA
34934 JMID=K+M
34935 W(M+1)=BETA*A(JMID)
34936 RETURN
34937
34938C get ND96 times chained 96 Gauss point array
34939
34940 3 CALL PHO_GAUDAT
34941C print out message
34942C -extract real points
34943 K=KTAB(96)
34944 ND96=N/96
34945 DO 31 J=1,48
34946C extract values from big array
34947 JTAB=K-1+J
34948 WTEMP=BETA*A(JTAB)
34949 DELTA=BETA*X(JTAB)
34950 WTeMP=WTEMP/ND96
34951 DeLTA=DELTA/ND96
34952 DO 32 JD96=0,ND96-1
34953 ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34954C store them backward
34955 Z(J+JD96*96)=ZCNTR-DELTA
34956 W(J+JD96*96)=WTEMP
34957C store them forward
34958 JP=96+1-J
34959 Z(JP+JD96*96)=ZCNTR+DELTA
34960 W(JP+JD96*96)=WTEMP
34961 32 CONTINUE
34962 31 CONTINUE
34963 RETURN
34964
34965C the center of intervall cases:
34966 100 CONTINUE
34967C put in constant weight and equally spaced central points
34968 N=IABS(N)
34969 DO 111 IN=1,N
34970 WIN=(BX-AX)/FLOAT(N)
34971 Z(IN)=AX + (FLOAT(IN)-.5)*WIN
34972 111 W(IN)=WIN
34973
34974 END
34975
34976*$ CREATE PHO_GAUDAT.FOR
34977*COPY PHO_GAUDAT
34978CDECK ID>, PHO_GAUDAT
34979 SUBROUTINE PHO_GAUDAT
34980C*********************************************************************
34981C
34982C store big arrays needed for Gauss integral, CERNLIB D106BD
34983C (arrays A,X,ITAB copied on B,Y,LTAB)
34984C
34985C*********************************************************************
34986 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34987
34988 SAVE
34989 COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34990 DIMENSION A(273),X(273),KTAB(96)
34991
34992C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34993 DATA KTAB(2)/1/
34994 DATA KTAB(3)/2/
34995 DATA KTAB(4)/4/
34996 DATA KTAB(5)/6/
34997 DATA KTAB(6)/9/
34998 DATA KTAB(7)/12/
34999 DATA KTAB(8)/16/
35000 DATA KTAB(9)/20/
35001 DATA KTAB(10)/25/
35002 DATA KTAB(11)/30/
35003 DATA KTAB(12)/36/
35004 DATA KTAB(13)/42/
35005 DATA KTAB(14)/49/
35006 DATA KTAB(15)/56/
35007 DATA KTAB(16)/64/
35008 DATA KTAB(20)/72/
35009 DATA KTAB(24)/82/
35010 DATA KTAB(28)/82/
35011 DATA KTAB(32)/94/
35012 DATA KTAB(36)/94/
35013 DATA KTAB(40)/110/
35014 DATA KTAB(44)/110/
35015 DATA KTAB(48)/130/
35016 DATA KTAB(52)/130/
35017 DATA KTAB(56)/130/
35018 DATA KTAB(60)/130/
35019 DATA KTAB(64)/154/
35020 DATA KTAB(68)/154/
35021 DATA KTAB(72)/154/
35022 DATA KTAB(76)/154/
35023 DATA KTAB(80)/186/
35024 DATA KTAB(84)/186/
35025 DATA KTAB(88)/186/
35026 DATA KTAB(92)/186/
35027 DATA KTAB(96)/226/
35028C
35029C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
35030C
35031C-----N=2
35032 DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
35033C-----N=3
35034 DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
35035 DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
35036C-----N=4
35037 DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
35038 DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
35039C-----N=5
35040 DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
35041 DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
35042 DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
35043C-----N=6
35044 DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
35045 DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
35046 DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
35047C-----N=7
35048 DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
35049 DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
35050 DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
35051 DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
35052C-----N=8
35053 DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
35054 DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
35055 DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
35056 DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
35057C-----N=9
35058 DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
35059 DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
35060 DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
35061 DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
35062 DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
35063C-----N=10
35064 DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
35065 DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
35066 DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
35067 DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
35068 DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
35069C-----N=11
35070 DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
35071 DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
35072 DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
35073 DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
35074 DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
35075 DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
35076C-----N=12
35077 DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
35078 DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
35079 DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
35080 DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
35081 DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
35082 DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
35083C-----N=13
35084 DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
35085 DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
35086 DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
35087 DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
35088 DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
35089 DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
35090 DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
35091C-----N=14
35092 DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
35093 DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
35094 DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
35095 DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
35096 DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
35097 DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
35098 DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
35099C-----N=15
35100 DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
35101 DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
35102 DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
35103 DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
35104 DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
35105 DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
35106 DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
35107 DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
35108C-----N=16
35109 DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
35110 DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
35111 DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
35112 DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
35113 DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
35114 DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
35115 DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
35116 DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
35117C-----N=20
35118 DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
35119 DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
35120 DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
35121 DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
35122 DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
35123 DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
35124 DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
35125 DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
35126 DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
35127 DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
35128C-----N=24
35129 DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
35130 DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
35131 DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
35132 DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
35133 DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
35134 DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
35135 DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
35136 DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
35137 DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
35138 DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
35139 DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
35140 DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
35141C-----N=32
35142 DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
35143 DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
35144 DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
35145 DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
35146 DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
35147 DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
35148 DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
35149 DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
35150 DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
35151 DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
35152 DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
35153 DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
35154 DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
35155 DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
35156 DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
35157 DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
35158C-----N=40
35159 DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
35160 DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
35161 DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
35162 DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
35163 DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
35164 DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
35165 DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
35166 DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
35167 DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
35168 DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
35169 DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
35170 DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
35171 DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
35172 DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
35173 DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
35174 DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
35175 DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
35176 DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
35177 DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
35178 DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
35179C-----N=48
35180 DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
35181 DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
35182 DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
35183 DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
35184 DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
35185 DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
35186 DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
35187 DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
35188 DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
35189 DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
35190 DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
35191 DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
35192 DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
35193 DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
35194 DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
35195 DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
35196 DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
35197 DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
35198 DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
35199 DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
35200 DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
35201 DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
35202 DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
35203 DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
35204C-----N=64
35205 DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
35206 DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
35207 DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
35208 DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
35209 DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
35210 DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
35211 DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
35212 DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
35213 DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
35214 DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
35215 DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
35216 DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
35217 DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
35218 DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
35219 DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
35220 DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
35221 DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
35222 DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
35223 DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
35224 DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
35225 DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
35226 DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
35227 DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
35228 DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
35229 DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
35230 DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
35231 DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
35232 DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
35233 DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
35234 DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
35235 DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
35236 DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
35237C-----N=80
35238 DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
35239 DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
35240 DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
35241 DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
35242 DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
35243 DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
35244 DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
35245 DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
35246 DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
35247 DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
35248 DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
35249 DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
35250 DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
35251 DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
35252 DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
35253 DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
35254 DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
35255 DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
35256 DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
35257 DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
35258 DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
35259 DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
35260 DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
35261 DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
35262 DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
35263 DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
35264 DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
35265 DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
35266 DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
35267 DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
35268 DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
35269 DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
35270 DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
35271 DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
35272 DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
35273 DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
35274 DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
35275 DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
35276 DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
35277 DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
35278C-----N=96
35279 DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
35280 DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
35281 DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
35282 DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
35283 DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
35284 DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
35285 DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
35286 DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
35287 DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
35288 DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
35289 DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
35290 DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
35291 DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
35292 DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
35293 DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
35294 DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
35295 DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
35296 DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
35297 DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
35298 DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
35299 DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
35300 DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
35301 DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
35302 DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
35303 DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
35304 DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
35305 DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
35306 DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
35307 DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
35308 DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
35309 DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
35310 DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
35311 DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
35312 DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
35313 DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
35314 DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
35315 DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
35316 DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
35317 DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
35318 DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
35319 DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
35320 DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
35321 DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
35322 DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
35323 DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
35324 DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
35325 DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
35326 DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
35327 DATA IBD/0/
35328 IF(IBD.NE.0) RETURN
35329 IBD=1
35330 DO 10 I=1,273
35331 B(I) = A(I)
35332 Y(I) = X(I)
35333 10 CONTINUE
35334 DO 20 I=1,96
35335 LTAB(I) = KTAB(I)
35336 20 CONTINUE
35337 END
35338
35339*$ CREATE PHO_DZEROX.FOR
35340*COPY PHO_DZEROX
35341CDECK ID>, PHO_DZEROX
35342 DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
35343C**********************************************************************
35344C
35345C Based on
35346C
35347C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
35348C Guaranteed Convergence for Finding a Zero of a Function,
35349C ACM Trans. Math. Software 1 (1975) 330-345.
35350C
35351C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
35352C
35353C CERNLIB C200
35354C
35355C***********************************************************************
35356 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35357 SAVE
35358
35359C input/output channels
35360 INTEGER LI,LO
35361 COMMON /POINOU/ LI,LO
35362
35363 CHARACTER NAME*(*)
35364 PARAMETER (NAME = 'PHO_DZEROX')
35365 LOGICAL LMT
35366 DIMENSION IM1(2),IM2(2),LMT(2)
35367 EXTERNAL F
35368
35369 PARAMETER (Z1 = 1, HALF = Z1/2)
35370
35371 DATA IM1 /2,3/, IM2 /-1,3/
35372
35373 IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
35374 C=-2D+10
35375 WRITE(LO,100) NAME,MODE
35376 GO TO 99
35377 ENDIF
35378 FA=F(B0)
35379 FB=F(A0)
35380 IF(FA*FB .GT. 0) THEN
35381 C=-3D+10
35382 WRITE(LO,101) NAME
35383 GO TO 99
35384 ENDIF
35385 ATL=ABS(EPS)
35386 B=A0
35387 A=B0
35388 LMT(2)=.TRUE.
35389 MF=2
35390 1 C=A
35391 FC=FA
35392 2 IE=0
35393 3 IF(ABS(FC) .LT. ABS(FB)) THEN
35394 IF(C .NE. A) THEN
35395 D=A
35396 FD=FA
35397 END IF
35398 A=B
35399 B=C
35400 C=A
35401 FA=FB
35402 FB=FC
35403 FC=FA
35404 END IF
35405 TOL=ATL*(1+ABS(C))
35406 H=HALF*(C+B)
35407 HB=H-B
35408 IF(ABS(HB) .GT. TOL) THEN
35409 IF(IE .GT. IM1(MODE)) THEN
35410 W=HB
35411 ELSE
35412 TOL=TOL*SIGN(Z1,HB)
35413 P=(B-A)*FB
35414 LMT(1)=IE .LE. 1
35415 IF(LMT(MODE)) THEN
35416 Q=FA-FB
35417 LMT(2)=.FALSE.
35418 ELSE
35419 FDB=(FD-FB)/(D-B)
35420 FDA=(FD-FA)/(D-A)
35421 P=FDA*P
35422 Q=FDB*FA-FDA*FB
35423 END IF
35424 IF(P .LT. 0) THEN
35425 P=-P
35426 Q=-Q
35427 END IF
35428 IF(IE .EQ. IM2(MODE)) P=P+P
35429 IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
35430 W=TOL
35431 ELSEIF(P .LT. HB*Q) THEN
35432 W=P/Q
35433 ELSE
35434 W=HB
35435 END IF
35436 END IF
35437 D=A
35438 A=B
35439 FD=FA
35440 FA=FB
35441 B=B+W
35442 MF=MF+1
35443 IF(MF .GT. MAXF) THEN
35444 WRITE(LO,102) NAME
35445 GO TO 99
35446 ENDIF
35447 FB=F(B)
35448 IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35449 IF(W .EQ. HB) GO TO 2
35450 IE=IE+1
35451 GO TO 3
35452 END IF
35453 99 CONTINUE
35454 PHO_DZEROX=C
35455 RETURN
35456 100 FORMAT(1X,A,': mode = ',I3,' illegal')
35457 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35458 102 FORMAT(1X,A,': too many function calls')
35459
35460 END
35461
35462*$ CREATE PHO_EXPINT.FOR
35463*COPY PHO_EXPINT
35464CDECK ID>, PHO_EXPINT
35465 DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35466C***********************************************************************
35467C
35468C function to calculate E_i(x) = -E_1(-x)
35469C
35470C based on CERNLIB C337 (changed by R.Engel 10/1993)
35471C
35472C***********************************************************************
35473 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35474 SAVE
35475
35476C input/output channels
35477 INTEGER LI,LO
35478 COMMON /POINOU/ LI,LO
35479
35480 DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35481 DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35482 DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35483
35484 DATA X0 /0.37250 74107 8137D0/
35485 DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35486 DATA P1
35487 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35488 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35489 3 -4.34981 43832 952D+2/
35490 DATA Q1
35491 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35492 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35493 3 +7.53585 64359 843D+2/
35494 DATA P2
35495 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35496 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35497 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35498 4 +4.65627 10797 510D-7/
35499 DATA Q2
35500 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35501 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35502 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35503 4 +1.00000 00000 000D+0/
35504 DATA P3
35505 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35506 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35507 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35508 DATA Q3
35509 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35510 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35511 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35512 DATA P4
35513 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35514 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35515 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35516 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35517 DATA Q4
35518 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35519 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35520 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35521 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35522 DATA A1
35523 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35524 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35525 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35526 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35527 DATA B1
35528 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35529 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35530 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35531 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35532 DATA A2
35533 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35534 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35535 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35536 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35537 DATA B2
35538 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35539 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35540 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35541 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35542 DATA A3
35543 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35544 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35545 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35546 DATA B3
35547 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35548 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35549 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35550C
35551C conversion to E_i function
35552 X = -RXM
35553C
35554 IF(X .LE. XL(1)) THEN
35555 AP=A3(1)-X
35556 DO 1 I = 2,5
35557 1 AP=A3(I)-X+B3(I)/AP
35558 Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35559 ELSEIF(X .LE. XL(2)) THEN
35560 AP=A2(1)-X
35561 DO 2 I = 2,7
35562 2 AP=A2(I)-X+B2(I)/AP
35563 Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35564 ELSEIF(X .LE. XL(3)) THEN
35565 AP=A1(1)-X
35566 DO 3 I = 2,7
35567 3 AP=A1(I)-X+B1(I)/AP
35568 Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35569 ELSEIF(X .LT. XL(4)) THEN
35570 V=-2.D0*(X/3.D0+1.D0)
35571 BP=0.D0
35572 DP=P4(1)
35573 DO 4 I = 2,8
35574 AP=BP
35575 BP=DP
35576 4 DP=P4(I)-AP+V*BP
35577 BQ=0.D0
35578 DQ=Q4(1)
35579 DO 14 I = 2,8
35580 AQ=BQ
35581 BQ=DQ
35582 14 DQ=Q4(I)-AQ+V*BQ
35583 Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35584 ELSEIF(X .EQ. XL(4)) THEN
35585* CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35586* IF(MFLAG) THEN
35587* IF(LGFILE .EQ. 0) THEN
35588* WRITE(LO,100) ENAME
35589* ELSE
35590* WRITE(LGFILE,100) ENAME
35591* ENDIF
35592* ENDIF
35593* IF(.NOT.RFLAG) CALL ABEND
35594 PHO_EXPINT=0.D0
35595 RETURN
35596 ELSEIF(X .LT. XL(5)) THEN
35597 AP=P1(1)
35598 AQ=Q1(1)
35599 DO 5 I = 2,5
35600 AP=P1(I)+X*AP
35601 5 AQ=Q1(I)+X*AQ
35602 Y=-LOG(X)+AP/AQ
35603 ELSEIF(X .LE. XL(6)) THEN
35604 Y=1.D0/X
35605 AP=P2(1)
35606 AQ=Q2(1)
35607 DO 6 I = 2,7
35608 AP=P2(I)+Y*AP
35609 6 AQ=Q2(I)+Y*AQ
35610 Y=EXP(-X)*AP/AQ
35611 ELSE
35612 Y=1.D0/X
35613 AP=P3(1)
35614 AQ=Q3(1)
35615 DO 7 I = 2,6
35616 AP=P3(I)+Y*AP
35617 7 AQ=Q3(I)+Y*AQ
35618 Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35619 ENDIF
35620C sign conversion to E_i
35621 PHO_EXPINT=-Y
35622
35623 END
35624
35625*$ CREATE PHO_RNDBET.FOR
35626*COPY PHO_RNDBET
35627CDECK ID>, PHO_RNDBET
35628 DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35629C********************************************************************
35630C
35631C RANDOM NUMBER GENERATION FROM BETA
35632C DISTRIBUTION IN REGION 0 < X < 1.
35633C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35634C *GAMM(ETA))
35635C
35636C********************************************************************
35637 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35638 SAVE
35639
35640 Y = PHO_RNDGAM(1.D0,GAM)
35641 Z = PHO_RNDGAM(1.D0,ETA)
35642
35643 PHO_RNDBET = Y/(Y+Z)
35644
35645 END
35646
35647*$ CREATE PHO_RNDGAM.FOR
35648*COPY PHO_RNDGAM
35649CDECK ID>, PHO_RNDGAM
35650 DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35651C********************************************************************
35652C
35653C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35654C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35655C
35656C********************************************************************
35657 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35658 SAVE
35659C
35660 NCOU=0
35661 N = ETA
35662 F = ETA - N
35663 IF(F.EQ.0.D0) GOTO 20
35664 10 R = DT_RNDM(ETA)
35665 NCOU=NCOU+1
35666 IF (NCOU.GE.11) GOTO 20
35667 IF(R.LT.F/(F+2.71828D0)) GOTO 30
35668 YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35669 IF(ABS(YYY).GT.50.D0) GOTO 20
35670 Y = EXP(YYY)
35671 IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35672 GOTO 40
35673 20 Y = 0.D0
35674 GOTO 50
35675 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35676 IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35677 40 IF(N.EQ.0) GOTO 70
35678 50 Z = 1.D0
35679 DO 60 I = 1,N
35680 60 Z = Z*DT_RNDM(Y)
35681 Y = Y-LOG(Z+1.0D-9)
35682 70 PHO_RNDGAM = Y/ALAM
35683 RETURN
35684 END
35685
35686*$ CREATE PHO_SFECFE.FOR
35687*COPY PHO_SFECFE
35688CDECK ID>, PHO_SFECFE
35689 SUBROUTINE PHO_SFECFE(SFE,CFE)
35690C**********************************************************************
35691C
35692C fast random SIN(X) COS(X) selection
35693C
35694C**********************************************************************
35695 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35696 SAVE
35697C
35698 1 CONTINUE
35699 X=DT_RNDM(XX)
35700 Y=DT_RNDM(YY)
35701 XX=X*X
35702 YY=Y*Y
35703 XY=XX+YY
35704 IF(XY.GT.1.D0) GOTO 1
35705 CFE=(XX-YY)/XY
35706 SFE=2.D0*X*Y/XY
35707 IF(DT_RNDM(XY).LT.0.5D0) THEN
35708 SFE=-SFE
35709 ENDIF
35710 END
35711
35712*$ CREATE PHO_SWAPD.FOR
35713*COPY PHO_SWAPD
35714CDECK ID>, PHO_SWAPD
35715 SUBROUTINE PHO_SWAPD(D1,D2)
35716C********************************************************************
35717C
35718C exchange of argument values (double precision)
35719C
35720C********************************************************************
35721 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35722 D = D1
35723 D1 = D2
35724 D2 = D
35725 END
35726
35727*$ CREATE PHO_SWAPI.FOR
35728*COPY PHO_SWAPI
35729CDECK ID>, PHO_SWAPI
35730 SUBROUTINE PHO_SWAPI(I1,I2)
35731C********************************************************************
35732C
35733C exchange of argument values (integer)
35734C
35735C********************************************************************
35736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35737 K = I1
35738 I1 = I2
35739 I2 = K
35740 END
35741
35742*$ CREATE PHO_HADCSL.FOR
35743*COPY PHO_HADCSL
35744CDECK ID>, PHO_HADCSL
35745 SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35746 & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35747C***********************************************************************
35748C
35749C low-energy cross section parametrizations
35750C
35751C input: ID1,ID2 PDG IDs of particles (meson first)
35752C ECM c.m. energy (GeV)
35753C PLAB lab. momentum (second particle at rest)
35754C IMODE 1 ECM given, PLAB ignored
35755C 2 PLAB given, ECM ignored
35756C
35757C output: SIGTOT total cross section (mb)
35758C SIGEL elastic cross section (mb)
35759C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
35760C SLOPE forward elastic slope (GeV**-2)
35761C RHO real/imaginary part of elastic amplitude
35762C
35763C comments:
35764C
35765C - low-energy data interpolation uses PDG fits from 1992 issue
35766C - high-energy extrapolation by Donnachie-Landshoff like fit made
35767C by PDG 1996
35768C - analytic extension of amplitude to calculate rho
35769C
35770C***********************************************************************
35771
35772 IMPLICIT NONE
35773
35774 SAVE
35775
35776 INTEGER ID1,ID2,IMODE
35777 DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35778
35779C input/output channels
35780 INTEGER LI,LO
35781 COMMON /POINOU/ LI,LO
35782C some constants
35783 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35784 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35785 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35786C model switches and parameters
35787 CHARACTER*8 MDLNA
35788 INTEGER ISWMDL,IPAMDL
35789 DOUBLE PRECISION PARMDL
35790 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35791
35792 INTEGER K
35793 DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35794 & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35795
35796 DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35797
35798 DATA TPDG92 /
35799 & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35800 & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35801 & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35802 & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35803 & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35804 & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35805 & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35806 & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35807 & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35808 & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35809 & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35810 & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
35811
35812 DATA TPDG96 /
35813 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35814 & 77.15D0,-21.05D0,0.46D0,0.9D0,
35815 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35816 & 77.15D0,21.05D0,0.46D0,0.9D0,
35817 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35818 & 31.85D0,-4.05D0,0.45D0,0.9D0,
35819 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35820 & 31.85D0,4.05D0,0.45D0,0.9D0,
35821 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35822 & 17.35D0,-9.05D0,0.50D0,0.9D0,
35823 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35824 & 17.35D0,9.05D0,0.50D0,0.9D0 /
35825
35826 DATA BURQ83 /
35827 & 11.13D0, -6.21D0, 0.30D0,
35828 & 11.13D0, 7.23D0, 0.30D0,
35829 & 9.11D0, -0.73D0, 0.28D0,
35830 & 9.11D0, 0.65D0, 0.28D0,
35831 & 8.55D0, -5.98D0, 0.28D0,
35832 & 8.55D0, 1.60D0, 0.28D0 /
35833
35834 DATA XMA /
35835 & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35836
35837C find index
35838 IF(ID2.NE.2212) THEN
35839 GOTO 100
35840 ELSE IF(ID1.EQ.2212) THEN
35841 K = 1
35842 ELSE IF(ID1.EQ.-2212) THEN
35843 K = 2
35844 ELSE IF(ID1.EQ.211) THEN
35845 K = 3
35846 ELSE IF(ID1.EQ.-211) THEN
35847 K = 4
35848 ELSE IF(ID1.EQ.321) THEN
35849 K = 5
35850 ELSE IF(ID1.EQ.-321) THEN
35851 K = 6
35852 ELSE
35853 GOTO 100
35854 ENDIF
35855
35856C calculate lab momentum
35857 IF(IMODE.EQ.1) THEN
35858 SS = ECM**2
35859 E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35860 PL = SQRT(E1*E1-XMA(K)**2)
35861 ELSE IF(IMODE.EQ.2) THEN
35862 PL = PLAB
35863 SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35864 ECM = SQRT(SS)
35865 ELSE
35866 WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35867 RETURN
35868 ENDIF
35869 PLL = LOG(PL)
35870
35871C check against lower limit
35872 IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35873
35874 XP = TPDG96(2,K)*SS**TPDG96(3,K)
35875 YP = TPDG96(6,K)/SS**TPDG96(8,K)
35876 YM = TPDG96(7,K)/SS**TPDG96(8,K)
35877
35878 PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35879 PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35880 RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35881 SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35882
35883C select energy range and interpolation method
35884 IF(PL.LT.TPDG96(1,K)) THEN
35885 SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35886 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35887 SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35888 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35889 ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35890 SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35891 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35892 SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35893 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35894 SIGTO2 = YP+YM+XP
35895 SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35896 X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35897 X1 = 1.D0 - X2
35898 SIGTOT = SIGTO2*X2 + SIGTO1*X1
35899 SIGEL = SIGEL2*X2 + SIGEL1*X1
35900 ELSE
35901 SIGTOT = YP+YM+XP
35902 SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35903 ENDIF
35904
35905C no parametrization of diffraction implemented
35906 SIGDIF(1) = -1.D0
35907 SIGDIF(2) = -1.D0
35908 SIGDIF(3) = -1.D0
35909
35910 RETURN
35911
35912 100 CONTINUE
35913 WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35914 & 'invalid particle combination: ',ID1,ID2
35915 RETURN
35916
35917 200 CONTINUE
35918 WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35919 & 'energy too small (Ecm,Plab): ',ECM,PLAB
35920
35921 END
35922
35923*$ CREATE PHO_CSDIFF.FOR
35924*COPY PHO_CSDIFF
35925CDECK ID>, PHO_CSDIFF
35926 SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35927 & sig_sd1,sig_sd2,sig_dd)
35928C***********************************************************************
35929C
35930C cross section for diffraction dissociation according to
35931C Goulianos' parametrization (Ref: PL B358 (1995) 379)
35932C
35933C in addition rescaling for different particles is applied using
35934C internal rescaling tables (not implemented yet)
35935C
35936C input: Id1/2 PDG ID's of incoming particles
35937C SS squared c.m. energy (GeV**2)
35938C Xi_min min. diff mass (squared) = Xi_min*SS
35939C Xi_max max. diff mass (squared) = Xi_max*SS
35940C
35941C output: sig_sd1 cross section for diss. of particle 1 (mb)
35942C sig_sd2 cross section for diss. of particle 2 (mb)
35943C sig_dd cross section for diss. of both particles
35944C
35945C***********************************************************************
35946
35947 IMPLICIT NONE
35948
35949 SAVE
35950
35951 INTEGER Id1,Id2
35952 DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35953
35954C input/output channels
35955 INTEGER LI,LO
35956 COMMON /POINOU/ LI,LO
35957C some constants
35958 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35959 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35960 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35961
35962 DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35963 DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35964 & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35965 & xms_1,xms_2,CSdiff
35966
35967 INTEGER Ngau1,Ngau2,i1,i2
35968
35969C model parameters
35970
35971 DATA delta / 0.104d0 /
35972 DATA alphap / 0.25d0 /
35973 DATA beta0 / 6.56d0 /
35974 DATA gpom0 / 1.21d0 /
35975 DATA xm_p / 0.938d0 /
35976 DATA x_rad2 / 0.71d0 /
35977
35978C integration precision
35979
35980 DATA Ngau1 / 96 /
35981 DATA Ngau2 / 96 /
35982
35983 sig_sd1 = 0.d0
35984 sig_sd2 = 0.d0
35985 sig_dd = 0.d0
35986
35987 IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35988
35989 xm4_p2 = 4.D0*xm_p**2
35990 fac = beta0**2/(16.D0*PI)
35991
35992 t1 = -5.D0
35993 t2 = 0.D0
35994 tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35995 tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35996
35997C flux renormalization and cross section
35998
35999 Xnorm = 0.d0
36000
36001 xil = log(1.5d0/SS)
36002 xiu = log(0.1d0)
36003
36004 IF(xiu.LE.xil) goto 1000
36005
36006 CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
36007 CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
36008
36009 do i1=1,Ngau1
36010
36011 xi = exp(xpos1(i1))
36012 w_xi = Xwgh1(i1)
36013
36014 do i2=1,Ngau2
36015
36016 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
36017
36018 alpha_t = 1.D0+delta+alphap*tt
36019 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
36020
36021 Xnorm = Xnorm
36022 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
36023
36024 enddo
36025 enddo
36026
36027 Xnorm = Xnorm*fac
36028
36029 1000 continue
36030
36031 XIL = LOG(Xi_min)
36032 XIU = LOG(Xi_max)
36033
36034 T1 = -5.D0
36035 T2 = 0.D0
36036
36037 TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
36038 TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
36039
36040C single diffraction diss. cross section
36041
36042 CSdiff = 0.d0
36043
36044 IF(XIU.LE.XIL) goto 2000
36045
36046 CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
36047 CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
36048
36049 do i1=1,Ngau1
36050
36051 xi = exp(xpos1(i1))
36052 w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
36053
36054 do i2=1,Ngau2
36055
36056 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
36057
36058 alpha_t = 1.D0+delta+alphap*tt
36059 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
36060
36061 CSdiff = CSdiff
36062 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
36063
36064 enddo
36065 enddo
36066
36067 CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
36068
36069* WRITE(LO,'(1x,1p,4e14.3)')
36070* & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
36071
36072 sig_sd1 = CSdiff
36073 sig_sd2 = CSdiff
36074
36075 2000 continue
36076
36077C double diffraction dissociation cross section
36078
36079 CSdiff = 0.d0
36080
36081 xil = log(1.5d0/SS)
36082 xiu = log(Xi_max/1.5d0)
36083
36084 IF(xiu.LE.xil) goto 3000
36085
36086 fac = (beta0*gpom0*SS**delta
36087 & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
36088 & /(2.d0*alphap)
36089
36090 CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
36091
36092 do i1=1,Ngau1
36093
36094 xi = exp(xpos1(i1))
36095 xms_1 = xi*SS
36096
36097 xiu = log(Xi_max/(xi*SS))
36098
36099 if(xil.lt.xiu) then
36100
36101 CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
36102
36103 do i2=1,Ngau2
36104
36105 xms_2 = exp(xpos2(i2))*SS
36106 CSdiff = CSdiff
36107 & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
36108 & *xwgh1(i1)*xwgh2(i2)
36109
36110 enddo
36111
36112 endif
36113
36114 enddo
36115
36116 sig_dd = CSdiff*fac*GEV2MB
36117
36118 3000 continue
36119
36120 ELSE
36121
36122 WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
36123 & 'invalid particle combination (Id1/2)',Id1,Id2
36124
36125 ENDIF
36126
36127 END
36128
36129*$ CREATE PHO_ALLM97.FOR
36130*COPY PHO_ALLM97
36131CDECK ID>, PHO_ALLM97
36132 DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
36133C**********************************************************************
36134C
36135C ALLM97 parametrization for gamma*-p cross section
36136C (for F2 see comments, code adapted from V. Shekelyan, H1)
36137C
36138C**********************************************************************
36139
36140 IMPLICIT NONE
36141
36142 SAVE
36143
36144C input/output channels
36145 INTEGER LI,LO
36146 COMMON /POINOU/ LI,LO
36147
36148 DOUBLE PRECISION Q2,W
36149 DOUBLE PRECISION M02,M12,LAM2,M22
36150 DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
36151 DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
36152 DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
36153 & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
36154 DATA ALFA,XMP2 /112.2D0 , .8802D0 /
36155
36156 W2=W*W
36157 PHO_ALLM97 = 0.D0
36158
36159C pomeron
36160 S11 = 0.28067D0
36161 S12 = 0.22291D0
36162 S13 = 2.1979D0
36163 A11 = -0.0808D0
36164 A12 = -0.44812D0
36165 A13 = 1.1709D0
36166 B11 = 0.60243D0
36167 B12 = 1.3754D0
36168 B13 = 1.8439D0
36169 M12 = 49.457D0
36170
36171C reggeon
36172 S21 = 0.80107D0
36173 S22 = 0.97307D0
36174 S23 = 3.4942D0
36175 A21 = 0.58400D0
36176 A22 = 0.37888D0
36177 A23 = 2.6063D0
36178 B21 = 0.10711D0
36179 B22 = 1.9386D0
36180 B23 = 0.49338D0
36181 M22 = 0.15052D0
36182C
36183 M02 = 0.31985D0
36184 LAM2 = 0.065270D0
36185 Q02 = 0.46017D0 +LAM2
36186
36187C
36188 S=0.
36189 T=LOG((Q2+Q02)/LAM2)
36190 T0=LOG(Q02/LAM2)
36191 IF(Q2.GT.0.D0) S=LOG(T/T0)
36192 Z=1.D0
36193
36194 IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
36195
36196 IF(S.LT.0.01D0) THEN
36197
36198C pomeron part
36199
36200 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
36201
36202 AP=A11
36203 BP=B11**2
36204
36205 SP=S11
36206 F2P=SP*XP**AP*Z**BP
36207
36208C reggeon part
36209
36210 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
36211
36212 AR=A21
36213 BR=B21**2
36214
36215 SR=S21
36216 F2R=SR*XR**AR*Z**BR
36217
36218 ELSE
36219
36220C pomeron part
36221
36222 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
36223
36224 AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
36225
36226 BP=B11**2+B12**2*S**B13
36227
36228 SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
36229
36230 F2P=SP*XP**AP*Z**BP
36231
36232C reggeon part
36233
36234 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
36235
36236 AR=A21+A22*S**A23
36237 BR=B21**2+B22**2*S**B23
36238
36239 SR=S21+S22*S**S23
36240 F2R=SR*XR**AR*Z**BR
36241
36242 ENDIF
36243
36244* F2 = (F2P+F2R)*Q2/(Q2+M02)
36245
36246 CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
36247 PHO_ALLM97 = CIN*(F2P+F2R)
36248
36249 END
36250
36251*$ CREATE PHO_DOR98LO.FOR
36252*COPY PHO_DOR98LO
36253CDECK ID>, PHO_DOR98LO
36254 SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
36255C***********************************************************************
36256C
36257C GRV98 parton densities, leading order set
36258C
36259C For a detailed explanation see
36260C M. Glueck, E. Reya, A. Vogt :
36261C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
36262C (To appear in Eur. Phys. J. C)
36263C
36264C interpolation routine based on the original GRV98PA routine,
36265C adapted to define interpolation table as DATA statements
36266C
36267C (R.Engel, 09/98)
36268C
36269C
36270C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
36271C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
36272C
36273C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
36274C DS = d(bar), SS = s = s(bar), GL = gluon.
36275C Always x times the distribution is returned.
36276C
36277C******************************************************i****************
36278 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
36279 SAVE
36280
36281C input/output channels
36282 INTEGER LI,LO
36283 COMMON /POINOU/ LI,LO
36284
36285 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
36286 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
36287 1 XSF(NX,NQ), XGF(NX,NQ),
36288 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
36289
36290 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
36291 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
36292
36293 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
36294 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
36295 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
36296 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
36297 EQUIVALENCE (XSF(1,1),XSF_L(1))
36298 EQUIVALENCE (XGF(1,1),XGF_L(1))
36299
36300 DATA (ARRF(K),K= 1, 95) /
36301 & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
36302 & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
36303 & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
36304 & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
36305 & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
36306 & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
36307 & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
36308 & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
36309 & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
36310 & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
36311 & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
36312 & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
36313 & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
36314 & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
36315 & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
36316 & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
36317 & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
36318 & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
36319 & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
36320 DATA (XUVF_L(K),K= 1, 114) /
36321 &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
36322 &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
36323 &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
36324 &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
36325 &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
36326 &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
36327 &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
36328 &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
36329 &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
36330 &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
36331 &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
36332 &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
36333 &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
36334 &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
36335 &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
36336 &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
36337 &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
36338 &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
36339 &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
36340 DATA (XUVF_L(K),K= 115, 228) /
36341 &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
36342 &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
36343 &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
36344 &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
36345 &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
36346 &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
36347 &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
36348 &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
36349 &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
36350 &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
36351 &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
36352 &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
36353 &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
36354 &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
36355 &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
36356 &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
36357 &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
36358 &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
36359 &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
36360 DATA (XUVF_L(K),K= 229, 342) /
36361 &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
36362 &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
36363 &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
36364 &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
36365 &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
36366 &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
36367 &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
36368 &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
36369 &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
36370 &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
36371 &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
36372 &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
36373 &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
36374 &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
36375 &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
36376 &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
36377 &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
36378 &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
36379 &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
36380 DATA (XUVF_L(K),K= 343, 456) /
36381 &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
36382 &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
36383 &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
36384 &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
36385 &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
36386 &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
36387 &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
36388 &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
36389 &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
36390 &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
36391 &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
36392 &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
36393 &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
36394 &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
36395 &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
36396 &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
36397 &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
36398 &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
36399 &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
36400 DATA (XUVF_L(K),K= 457, 570) /
36401 &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
36402 &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
36403 &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
36404 &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
36405 &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
36406 &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
36407 &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
36408 &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
36409 &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
36410 &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
36411 &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
36412 &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
36413 &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
36414 &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
36415 &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
36416 &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
36417 &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
36418 &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
36419 &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
36420 DATA (XUVF_L(K),K= 571, 684) /
36421 &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
36422 &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
36423 &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
36424 &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
36425 &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
36426 &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
36427 &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
36428 &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
36429 &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
36430 &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
36431 &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
36432 &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
36433 &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
36434 &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
36435 &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
36436 &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
36437 &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
36438 &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
36439 &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
36440 DATA (XUVF_L(K),K= 685, 798) /
36441 &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
36442 &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36443 &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36444 &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36445 &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36446 &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36447 &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36448 &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36449 &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36450 &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36451 &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36452 &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36453 &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36454 &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36455 &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36456 &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36457 &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36458 &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36459 &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36460 DATA (XUVF_L(K),K= 799, 912) /
36461 &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36462 &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36463 &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36464 &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36465 &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36466 &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36467 &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36468 &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36469 &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36470 &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36471 &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36472 &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36473 &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36474 &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36475 &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36476 &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36477 &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36478 &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36479 &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36480 DATA (XUVF_L(K),K= 913, 1026) /
36481 &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36482 &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36483 &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36484 &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36485 &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36486 &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36487 &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36488 &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36489 &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36490 &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36491 &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36492 &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36493 &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36494 &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36495 &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36496 &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36497 &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36498 &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36499 &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36500 DATA (XUVF_L(K),K= 1027, 1140) /
36501 &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36502 &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36503 &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36504 &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36505 &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36506 &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36507 &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36508 &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36509 &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36510 &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36511 &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36512 &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36513 &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36514 &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36515 &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36516 &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36517 &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36518 &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36519 &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36520 DATA (XUVF_L(K),K= 1141, 1254) /
36521 &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36522 &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36523 &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36524 &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36525 &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36526 &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36527 &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36528 &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36529 &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36530 &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36531 &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36532 &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36533 &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36534 &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36535 &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36536 &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36537 &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36538 &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36539 &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36540 DATA (XUVF_L(K),K= 1255, 1368) /
36541 &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36542 &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36543 &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36544 &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36545 &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36546 &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36547 &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36548 &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36549 &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36550 &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36551 &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36552 &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36553 &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36554 &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36555 &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36556 &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36557 &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36558 &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36559 &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36560 DATA (XUVF_L(K),K= 1369, 1482) /
36561 &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36562 &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36563 &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36564 &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36565 &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36566 &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36567 &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36568 &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36569 &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36570 &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36571 &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36572 &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36573 &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36574 &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36575 &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36576 &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36577 &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36578 &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36579 &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36580 DATA (XUVF_L(K),K= 1483, 1596) /
36581 &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36582 &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36583 &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36584 &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36585 &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36586 &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36587 &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36588 &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36589 &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36590 &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36591 &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36592 &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36593 &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36594 &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36595 &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36596 &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36597 &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36598 &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36599 &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36600 DATA (XUVF_L(K),K= 1597, 1710) /
36601 &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36602 &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36603 &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36604 &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36605 &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36606 &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36607 &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36608 &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36609 &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36610 &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36611 &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36612 &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36613 &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36614 &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36615 &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36616 &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36617 &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36618 &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36619 &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36620 DATA (XUVF_L(K),K= 1711, 1824) /
36621 &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36622 &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36623 &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36624 &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36625 &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36626 &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36627 &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36628 &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36629 &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36630 &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36631 &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36632 &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36633 &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36634 &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36635 &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36636 &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36637 &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36638 &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36639 &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36640 DATA (XUVF_L(K),K= 1825, 1836) /
36641 &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36642 &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36643 DATA (XDVF_L(K),K= 1, 114) /
36644 &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36645 &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36646 &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36647 &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36648 &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36649 &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36650 &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36651 &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36652 &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36653 &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36654 &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36655 &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36656 &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36657 &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36658 &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36659 &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36660 &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36661 &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36662 &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36663 DATA (XDVF_L(K),K= 115, 228) /
36664 &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36665 &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36666 &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36667 &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36668 &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36669 &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36670 &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36671 &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36672 &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36673 &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36674 &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36675 &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36676 &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36677 &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36678 &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36679 &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36680 &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36681 &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36682 &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36683 DATA (XDVF_L(K),K= 229, 342) /
36684 &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36685 &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36686 &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36687 &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36688 &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36689 &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36690 &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36691 &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36692 &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36693 &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36694 &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36695 &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36696 &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36697 &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36698 &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36699 &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36700 &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36701 &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36702 &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36703 DATA (XDVF_L(K),K= 343, 456) /
36704 &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36705 &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36706 &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36707 &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36708 &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36709 &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36710 &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36711 &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36712 &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36713 &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36714 &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36715 &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36716 &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36717 &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36718 &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36719 &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36720 &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36721 &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36722 &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36723 DATA (XDVF_L(K),K= 457, 570) /
36724 &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36725 &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36726 &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36727 &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36728 &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36729 &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36730 &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36731 &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36732 &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36733 &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36734 &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36735 &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36736 &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36737 &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36738 &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36739 &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36740 &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36741 &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36742 &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36743 DATA (XDVF_L(K),K= 571, 684) /
36744 &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36745 &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36746 &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36747 &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36748 &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36749 &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36750 &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36751 &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36752 &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36753 &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36754 &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36755 &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36756 &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36757 &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36758 &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36759 &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36760 &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36761 &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36762 &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36763 DATA (XDVF_L(K),K= 685, 798) /
36764 &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36765 &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36766 &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36767 &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36768 &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36769 &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36770 &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36771 &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36772 &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36773 &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36774 &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36775 &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36776 &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36777 &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36778 &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36779 &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36780 &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36781 &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36782 &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36783 DATA (XDVF_L(K),K= 799, 912) /
36784 &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36785 &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36786 &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36787 &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36788 &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36789 &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36790 &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36791 &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36792 &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36793 &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36794 &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36795 &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36796 &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36797 &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36798 &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36799 &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36800 &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36801 &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36802 &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36803 DATA (XDVF_L(K),K= 913, 1026) /
36804 &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36805 &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36806 &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36807 &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36808 &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36809 &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36810 &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36811 &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36812 &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36813 &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36814 &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36815 &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36816 &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36817 &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36818 &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36819 &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36820 &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36821 &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36822 &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36823 DATA (XDVF_L(K),K= 1027, 1140) /
36824 &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36825 &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36826 &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36827 &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36828 &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36829 &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36830 &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36831 &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36832 &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36833 &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36834 &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36835 &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36836 &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36837 &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36838 &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36839 &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36840 &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36841 &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36842 &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36843 DATA (XDVF_L(K),K= 1141, 1254) /
36844 &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36845 &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36846 &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36847 &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36848 &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36849 &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36850 &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36851 &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36852 &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36853 &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36854 &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36855 &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36856 &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36857 &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36858 &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36859 &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36860 &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36861 &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36862 &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36863 DATA (XDVF_L(K),K= 1255, 1368) /
36864 &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36865 &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36866 &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36867 &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36868 &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36869 &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36870 &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36871 &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36872 &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36873 &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36874 &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36875 &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36876 &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36877 &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36878 &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36879 &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36880 &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36881 &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36882 &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36883 DATA (XDVF_L(K),K= 1369, 1482) /
36884 &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36885 &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36886 &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36887 &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36888 &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36889 &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36890 &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36891 &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36892 &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36893 &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36894 &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36895 &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36896 &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36897 &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36898 &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36899 &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36900 &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36901 &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36902 &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36903 DATA (XDVF_L(K),K= 1483, 1596) /
36904 &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36905 &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36906 &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36907 &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36908 &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36909 &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36910 &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36911 &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36912 &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36913 &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36914 &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36915 &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36916 &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36917 &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36918 &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36919 &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36920 &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36921 &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36922 &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36923 DATA (XDVF_L(K),K= 1597, 1710) /
36924 &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36925 &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36926 &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36927 &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36928 &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36929 &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36930 &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36931 &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36932 &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36933 &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36934 &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36935 &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36936 &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36937 &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36938 &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36939 &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36940 &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36941 &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36942 &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36943 DATA (XDVF_L(K),K= 1711, 1824) /
36944 &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36945 &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36946 &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36947 &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36948 &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36949 &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36950 &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36951 &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36952 &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36953 &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36954 &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36955 &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36956 &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36957 &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36958 &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36959 &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36960 &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36961 &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36962 &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36963 DATA (XDVF_L(K),K= 1825, 1836) /
36964 &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36965 &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36966 DATA (XDEF_L(K),K= 1, 114) /
36967 &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36968 &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36969 &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36970 &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36971 &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36972 &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36973 &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36974 &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36975 &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36976 &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36977 &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36978 &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36979 &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36980 &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36981 &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36982 &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36983 &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36984 &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36985 &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36986 DATA (XDEF_L(K),K= 115, 228) /
36987 &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36988 &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36989 &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36990 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36991 &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36992 &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36993 &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36994 &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36995 &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36996 &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36997 &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36998 &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36999 &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
37000 &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
37001 &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37002 &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
37003 &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
37004 &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
37005 &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
37006 DATA (XDEF_L(K),K= 229, 342) /
37007 &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
37008 &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
37009 &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
37010 &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
37011 &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
37012 &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
37013 &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
37014 &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
37015 &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
37016 &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
37017 &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
37018 &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
37019 &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
37020 &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
37021 &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
37022 &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
37023 &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
37024 &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
37025 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
37026 DATA (XDEF_L(K),K= 343, 456) /
37027 &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
37028 &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
37029 &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
37030 &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
37031 &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
37032 &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
37033 &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
37034 &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
37035 &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
37036 &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
37037 &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37038 &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
37039 &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
37040 &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
37041 &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
37042 &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
37043 &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
37044 &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
37045 &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
37046 DATA (XDEF_L(K),K= 457, 570) /
37047 &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
37048 &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
37049 &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
37050 &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
37051 &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
37052 &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
37053 &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
37054 &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
37055 &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
37056 &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
37057 &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
37058 &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
37059 &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
37060 &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
37061 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
37062 &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
37063 &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
37064 &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
37065 &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
37066 DATA (XDEF_L(K),K= 571, 684) /
37067 &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
37068 &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
37069 &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
37070 &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
37071 &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
37072 &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
37073 &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37074 &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
37075 &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
37076 &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
37077 &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
37078 &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
37079 &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
37080 &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
37081 &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
37082 &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
37083 &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
37084 &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
37085 &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
37086 DATA (XDEF_L(K),K= 685, 798) /
37087 &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
37088 &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
37089 &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
37090 &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
37091 &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
37092 &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
37093 &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
37094 &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
37095 &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
37096 &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
37097 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
37098 &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
37099 &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
37100 &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
37101 &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
37102 &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
37103 &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
37104 &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
37105 &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
37106 DATA (XDEF_L(K),K= 799, 912) /
37107 &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
37108 &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
37109 &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37110 &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
37111 &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
37112 &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
37113 &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
37114 &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
37115 &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
37116 &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
37117 &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
37118 &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
37119 &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
37120 &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37121 &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
37122 &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
37123 &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
37124 &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
37125 &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
37126 DATA (XDEF_L(K),K= 913, 1026) /
37127 &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
37128 &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
37129 &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
37130 &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
37131 &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
37132 &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
37133 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
37134 &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
37135 &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
37136 &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
37137 &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
37138 &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
37139 &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
37140 &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
37141 &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
37142 &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
37143 &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
37144 &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37145 &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
37146 DATA (XDEF_L(K),K= 1027, 1140) /
37147 &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
37148 &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
37149 &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
37150 &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
37151 &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
37152 &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
37153 &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
37154 &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
37155 &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
37156 &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37157 &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
37158 &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
37159 &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
37160 &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
37161 &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
37162 &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
37163 &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
37164 &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
37165 &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
37166 DATA (XDEF_L(K),K= 1141, 1254) /
37167 &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
37168 &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
37169 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
37170 &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
37171 &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
37172 &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
37173 &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
37174 &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
37175 &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
37176 &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
37177 &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
37178 &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
37179 &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
37180 &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37181 &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
37182 &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
37183 &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
37184 &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
37185 &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
37186 DATA (XDEF_L(K),K= 1255, 1368) /
37187 &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
37188 &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
37189 &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
37190 &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
37191 &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
37192 &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37193 &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
37194 &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
37195 &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
37196 &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
37197 &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
37198 &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
37199 &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
37200 &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
37201 &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
37202 &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
37203 &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
37204 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
37205 &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
37206 DATA (XDEF_L(K),K= 1369, 1482) /
37207 &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
37208 &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
37209 &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
37210 &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
37211 &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
37212 &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
37213 &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
37214 &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
37215 &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
37216 &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37217 &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
37218 &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
37219 &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
37220 &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
37221 &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
37222 &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
37223 &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
37224 &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
37225 &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
37226 DATA (XDEF_L(K),K= 1483, 1596) /
37227 &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
37228 &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37229 &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
37230 &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
37231 &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
37232 &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
37233 &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
37234 &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
37235 &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
37236 &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
37237 &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
37238 &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
37239 &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
37240 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
37241 &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
37242 &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
37243 &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
37244 &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
37245 &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
37246 DATA (XDEF_L(K),K= 1597, 1710) /
37247 &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
37248 &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
37249 &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
37250 &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
37251 &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
37252 &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37253 &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
37254 &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
37255 &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
37256 &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
37257 &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
37258 &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
37259 &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
37260 &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
37261 &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
37262 &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
37263 &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37264 &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
37265 &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
37266 DATA (XDEF_L(K),K= 1711, 1824) /
37267 &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
37268 &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
37269 &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
37270 &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
37271 &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
37272 &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
37273 &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
37274 &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
37275 &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
37276 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
37277 &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
37278 &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
37279 &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
37280 &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
37281 &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
37282 &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
37283 &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
37284 &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
37285 &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
37286 DATA (XDEF_L(K),K= 1825, 1836) /
37287 &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
37288 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
37289 DATA (XUDF_L(K),K= 1, 114) /
37290 &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
37291 &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
37292 &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
37293 &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
37294 &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
37295 &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
37296 &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
37297 &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
37298 &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
37299 &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
37300 &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
37301 &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
37302 &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
37303 &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
37304 &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
37305 &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
37306 &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
37307 &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
37308 &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
37309 DATA (XUDF_L(K),K= 115, 228) /
37310 &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
37311 &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
37312 &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
37313 &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
37314 &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
37315 &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
37316 &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
37317 &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
37318 &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
37319 &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
37320 &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
37321 &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
37322 &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
37323 &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
37324 &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
37325 &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
37326 &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
37327 &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
37328 &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
37329 DATA (XUDF_L(K),K= 229, 342) /
37330 &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
37331 &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
37332 &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
37333 &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
37334 &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
37335 &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
37336 &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
37337 &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
37338 &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
37339 &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
37340 &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
37341 &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
37342 &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
37343 &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
37344 &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
37345 &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
37346 &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
37347 &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
37348 &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
37349 DATA (XUDF_L(K),K= 343, 456) /
37350 &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
37351 &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
37352 &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
37353 &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
37354 &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
37355 &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
37356 &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
37357 &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
37358 &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
37359 &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
37360 &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
37361 &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
37362 &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
37363 &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
37364 &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
37365 &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
37366 &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
37367 &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
37368 &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
37369 DATA (XUDF_L(K),K= 457, 570) /
37370 &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
37371 &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
37372 &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
37373 &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
37374 &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
37375 &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
37376 &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
37377 &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
37378 &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
37379 &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
37380 &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
37381 &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
37382 &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
37383 &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
37384 &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
37385 &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
37386 &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
37387 &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
37388 &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
37389 DATA (XUDF_L(K),K= 571, 684) /
37390 &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
37391 &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
37392 &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
37393 &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
37394 &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
37395 &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
37396 &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
37397 &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
37398 &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
37399 &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
37400 &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
37401 &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
37402 &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
37403 &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
37404 &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
37405 &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
37406 &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
37407 &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
37408 &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
37409 DATA (XUDF_L(K),K= 685, 798) /
37410 &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
37411 &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
37412 &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
37413 &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
37414 &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
37415 &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
37416 &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
37417 &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
37418 &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
37419 &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
37420 &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
37421 &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
37422 &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
37423 &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
37424 &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
37425 &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
37426 &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
37427 &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
37428 &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
37429 DATA (XUDF_L(K),K= 799, 912) /
37430 &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
37431 &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
37432 &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
37433 &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
37434 &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
37435 &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
37436 &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
37437 &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
37438 &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
37439 &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
37440 &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
37441 &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
37442 &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37443 &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37444 &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37445 &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37446 &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37447 &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37448 &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37449 DATA (XUDF_L(K),K= 913, 1026) /
37450 &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37451 &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37452 &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37453 &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37454 &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37455 &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37456 &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37457 &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37458 &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37459 &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37460 &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37461 &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37462 &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37463 &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37464 &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37465 &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37466 &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37467 &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37468 &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37469 DATA (XUDF_L(K),K= 1027, 1140) /
37470 &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37471 &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37472 &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37473 &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37474 &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37475 &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37476 &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37477 &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37478 &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37479 &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37480 &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37481 &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37482 &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37483 &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37484 &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37485 &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37486 &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37487 &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37488 &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37489 DATA (XUDF_L(K),K= 1141, 1254) /
37490 &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37491 &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37492 &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37493 &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37494 &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37495 &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37496 &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37497 &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37498 &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37499 &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37500 &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37501 &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37502 &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37503 &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37504 &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37505 &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37506 &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37507 &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37508 &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37509 DATA (XUDF_L(K),K= 1255, 1368) /
37510 &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37511 &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37512 &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37513 &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37514 &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37515 &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37516 &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37517 &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37518 &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37519 &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37520 &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37521 &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37522 &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37523 &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37524 &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37525 &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37526 &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37527 &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37528 &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37529 DATA (XUDF_L(K),K= 1369, 1482) /
37530 &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37531 &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37532 &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37533 &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37534 &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37535 &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37536 &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37537 &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37538 &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37539 &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37540 &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37541 &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37542 &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37543 &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37544 &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37545 &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37546 &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37547 &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37548 &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37549 DATA (XUDF_L(K),K= 1483, 1596) /
37550 &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37551 &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37552 &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37553 &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37554 &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37555 &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37556 &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37557 &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37558 &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37559 &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37560 &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37561 &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37562 &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37563 &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37564 &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37565 &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37566 &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37567 &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37568 &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37569 DATA (XUDF_L(K),K= 1597, 1710) /
37570 &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37571 &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37572 &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37573 &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37574 &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37575 &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37576 &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37577 &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37578 &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37579 &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37580 &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37581 &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37582 &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37583 &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37584 &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37585 &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37586 &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37587 &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37588 &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37589 DATA (XUDF_L(K),K= 1711, 1824) /
37590 &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37591 &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37592 &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37593 &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37594 &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37595 &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37596 &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37597 &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37598 &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37599 &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37600 &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37601 &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37602 &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37603 &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37604 &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37605 &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37606 &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37607 &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37608 &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37609 DATA (XUDF_L(K),K= 1825, 1836) /
37610 &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37611 &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37612 DATA (XSF_L(K),K= 1, 114) /
37613 &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37614 &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37615 &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37616 &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37617 &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37618 &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37619 &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37620 &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37621 &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37622 &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37623 &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37624 &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37625 &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37626 &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37627 &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37628 &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37629 &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37630 &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37631 &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37632 DATA (XSF_L(K),K= 115, 228) /
37633 &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37634 &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37635 &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37636 &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37637 &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37638 &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37639 &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37640 &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37641 &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37642 &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37643 &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37644 &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37645 &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37646 &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37647 &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37648 &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37649 &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37650 &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37651 &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37652 DATA (XSF_L(K),K= 229, 342) /
37653 &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37654 &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37655 &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37656 &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37657 &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37658 &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37659 &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37660 &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37661 &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37662 &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37663 &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37664 &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37665 &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37666 &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37667 &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37668 &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37669 &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37670 &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37671 &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37672 DATA (XSF_L(K),K= 343, 456) /
37673 &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37674 &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37675 &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37676 &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37677 &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37678 &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37679 &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37680 &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37681 &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37682 &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37683 &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37684 &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37685 &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37686 &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37687 &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37688 &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37689 &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37690 &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37691 &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37692 DATA (XSF_L(K),K= 457, 570) /
37693 &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37694 &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37695 &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37696 &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37697 &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37698 &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37699 &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37700 &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37701 &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37702 &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37703 &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37704 &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37705 &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37706 &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37707 &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37708 &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37709 &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37710 &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37711 &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37712 DATA (XSF_L(K),K= 571, 684) /
37713 &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37714 &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37715 &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37716 &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37717 &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37718 &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37719 &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37720 &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37721 &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37722 &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37723 &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37724 &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37725 &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37726 &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37727 &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37728 &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37729 &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37730 &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37731 &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37732 DATA (XSF_L(K),K= 685, 798) /
37733 &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37734 &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37735 &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37736 &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37737 &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37738 &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37739 &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37740 &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37741 &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37742 &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37743 &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37744 &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37745 &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37746 &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37747 &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37748 &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37749 &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37750 &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37751 &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37752 DATA (XSF_L(K),K= 799, 912) /
37753 &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37754 &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37755 &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37756 &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37757 &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37758 &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37759 &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37760 &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37761 &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37762 &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37763 &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37764 &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37765 &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37766 &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37767 &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37768 &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37769 &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37770 &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37771 &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37772 DATA (XSF_L(K),K= 913, 1026) /
37773 &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37774 &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37775 &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37776 &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37777 &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37778 &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37779 &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37780 &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37781 &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37782 &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37783 &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37784 &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37785 &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37786 &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37787 &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37788 &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37789 &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37790 &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37791 &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37792 DATA (XSF_L(K),K= 1027, 1140) /
37793 &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37794 &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37795 &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37796 &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37797 &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37798 &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37799 &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37800 &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37801 &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37802 &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37803 &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37804 &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37805 &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37806 &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37807 &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37808 &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37809 &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37810 &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37811 &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37812 DATA (XSF_L(K),K= 1141, 1254) /
37813 &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37814 &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37815 &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37816 &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37817 &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37818 &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37819 &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37820 &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37821 &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37822 &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37823 &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37824 &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37825 &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37826 &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37827 &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37828 &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37829 &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37830 &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37831 &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37832 DATA (XSF_L(K),K= 1255, 1368) /
37833 &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37834 &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37835 &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37836 &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37837 &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37838 &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37839 &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37840 &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37841 &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37842 &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37843 &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37844 &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37845 &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37846 &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37847 &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37848 &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37849 &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37850 &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37851 &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37852 DATA (XSF_L(K),K= 1369, 1482) /
37853 &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37854 &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37855 &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37856 &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37857 &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37858 &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37859 &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37860 &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37861 &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37862 &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37863 &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37864 &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37865 &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37866 &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37867 &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37868 &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37869 &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37870 &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37871 &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37872 DATA (XSF_L(K),K= 1483, 1596) /
37873 &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37874 &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37875 &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37876 &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37877 &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37878 &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37879 &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37880 &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37881 &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37882 &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37883 &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37884 &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37885 &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37886 &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37887 &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37888 &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37889 &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37890 &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37891 &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37892 DATA (XSF_L(K),K= 1597, 1710) /
37893 &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37894 &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37895 &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37896 &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37897 &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37898 &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37899 &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37900 &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37901 &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37902 &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37903 &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37904 &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37905 &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37906 &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37907 &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37908 &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37909 &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37910 &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37911 &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37912 DATA (XSF_L(K),K= 1711, 1824) /
37913 &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37914 &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37915 &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37916 &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37917 &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37918 &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37919 &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37920 &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37921 &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37922 &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37923 &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37924 &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37925 &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37926 &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37927 &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37928 &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37929 &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37930 &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37931 &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37932 DATA (XSF_L(K),K= 1825, 1836) /
37933 &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37934 &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37935 DATA (XGF_L(K),K= 1, 114) /
37936 &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37937 &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37938 &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37939 &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37940 &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37941 &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37942 &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37943 &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37944 &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37945 &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37946 &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37947 &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37948 &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37949 &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37950 &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37951 &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37952 &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37953 &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37954 &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37955 DATA (XGF_L(K),K= 115, 228) /
37956 &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37957 &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37958 &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37959 &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37960 &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37961 &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37962 &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37963 &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37964 &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37965 &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37966 &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37967 &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37968 &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37969 &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37970 &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37971 &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37972 &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37973 &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37974 &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37975 DATA (XGF_L(K),K= 229, 342) /
37976 &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37977 &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37978 &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37979 &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37980 &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37981 &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37982 &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37983 &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37984 &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37985 &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37986 &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37987 &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37988 &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37989 &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37990 &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37991 &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37992 &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37993 &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37994 &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37995 DATA (XGF_L(K),K= 343, 456) /
37996 &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37997 &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37998 &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37999 &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
38000 &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
38001 &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
38002 &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
38003 &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
38004 &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
38005 &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
38006 &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
38007 &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
38008 &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
38009 &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
38010 &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
38011 &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
38012 &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
38013 &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
38014 &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
38015 DATA (XGF_L(K),K= 457, 570) /
38016 &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
38017 &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
38018 &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
38019 &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
38020 &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
38021 &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
38022 &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
38023 &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
38024 &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
38025 &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
38026 &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
38027 &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
38028 &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
38029 &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
38030 &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
38031 &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
38032 &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
38033 &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
38034 &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
38035 DATA (XGF_L(K),K= 571, 684) /
38036 &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
38037 &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
38038 &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
38039 &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
38040 &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
38041 &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
38042 &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
38043 &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
38044 &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
38045 &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
38046 &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
38047 &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
38048 &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
38049 &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
38050 &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
38051 &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
38052 &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
38053 &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
38054 &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
38055 DATA (XGF_L(K),K= 685, 798) /
38056 &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
38057 &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
38058 &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
38059 &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
38060 &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
38061 &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
38062 &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
38063 &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
38064 &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
38065 &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
38066 &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
38067 &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
38068 &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
38069 &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
38070 &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
38071 &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
38072 &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
38073 &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
38074 &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
38075 DATA (XGF_L(K),K= 799, 912) /
38076 &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
38077 &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
38078 &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
38079 &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
38080 &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
38081 &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
38082 &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
38083 &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
38084 &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
38085 &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
38086 &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
38087 &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
38088 &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
38089 &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
38090 &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
38091 &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
38092 &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
38093 &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
38094 &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
38095 DATA (XGF_L(K),K= 913, 1026) /
38096 &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
38097 &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
38098 &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
38099 &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
38100 &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
38101 &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
38102 &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
38103 &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
38104 &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
38105 &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
38106 &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
38107 &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
38108 &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
38109 &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
38110 &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
38111 &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
38112 &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
38113 &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
38114 &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
38115 DATA (XGF_L(K),K= 1027, 1140) /
38116 &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
38117 &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
38118 &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
38119 &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
38120 &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
38121 &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
38122 &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
38123 &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
38124 &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
38125 &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
38126 &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
38127 &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
38128 &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
38129 &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
38130 &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
38131 &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
38132 &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
38133 &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
38134 &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
38135 DATA (XGF_L(K),K= 1141, 1254) /
38136 &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
38137 &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
38138 &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
38139 &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
38140 &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
38141 &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
38142 &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
38143 &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
38144 &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
38145 &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
38146 &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
38147 &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
38148 &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
38149 &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
38150 &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
38151 &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
38152 &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
38153 &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
38154 &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
38155 DATA (XGF_L(K),K= 1255, 1368) /
38156 &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
38157 &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
38158 &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
38159 &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
38160 &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
38161 &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
38162 &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
38163 &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
38164 &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
38165 &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
38166 &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
38167 &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
38168 &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
38169 &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
38170 &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
38171 &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
38172 &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
38173 &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
38174 &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
38175 DATA (XGF_L(K),K= 1369, 1482) /
38176 &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
38177 &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
38178 &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
38179 &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
38180 &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
38181 &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
38182 &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
38183 &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
38184 &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
38185 &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
38186 &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
38187 &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
38188 &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
38189 &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
38190 &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
38191 &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
38192 &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
38193 &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
38194 &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
38195 DATA (XGF_L(K),K= 1483, 1596) /
38196 &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
38197 &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
38198 &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
38199 &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
38200 &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
38201 &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
38202 &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
38203 &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
38204 &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
38205 &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
38206 &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
38207 &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
38208 &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
38209 &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
38210 &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
38211 &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
38212 &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
38213 &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
38214 &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
38215 DATA (XGF_L(K),K= 1597, 1710) /
38216 &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
38217 &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
38218 &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
38219 &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
38220 &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
38221 &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
38222 &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
38223 &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
38224 &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
38225 &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
38226 &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
38227 &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
38228 &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
38229 &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
38230 &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
38231 &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
38232 &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
38233 &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
38234 &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
38235 DATA (XGF_L(K),K= 1711, 1824) /
38236 &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
38237 &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
38238 &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
38239 &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
38240 &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
38241 &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
38242 &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
38243 &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
38244 &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
38245 &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
38246 &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
38247 &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
38248 &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
38249 &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
38250 &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
38251 &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
38252 &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
38253 &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
38254 &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
38255 DATA (XGF_L(K),K= 1825, 1836) /
38256 &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
38257 &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
38258
38259*
38260 X = Xinp
38261*...CHECK OF X AND Q2 VALUES :
38262 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
38263* WRITE(LO,91) X
38264 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
38265 X = 0.99D-9
38266* STOP
38267 ENDIF
38268
38269 Q2 = Q2inp
38270 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
38271* WRITE(LO,92) Q2
38272 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
38273 Q2 = 0.99E6
38274* STOP
38275 ENDIF
38276
38277*
38278*...INTERPOLATION :
38279 NA(1) = NX
38280 NA(2) = NQ
38281 XT(1) = DLOG(X)
38282 XT(2) = DLOG(Q2)
38283 X1 = 1.- X
38284 XV = X**0.5
38285 XS = X**(-0.2)
38286 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
38287 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
38288 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
38289 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
38290 US = 0.5 * (UD - DE)
38291 DS = 0.5 * (UD + DE)
38292 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
38293 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
38294
38295 END
38296
38297*$ CREATE PHO_DOR98SC.FOR
38298*COPY PHO_DOR98SC
38299CDECK ID>, PHO_DOR98SC
38300 SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
38301C***********************************************************************
38302C
38303C GRV98 parton densities, leading order set
38304C
38305C For a detailed explanation see
38306C M. Glueck, E. Reya, A. Vogt :
38307C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
38308C (To appear in Eur. Phys. J. C)
38309C
38310C interpolation routine based on the original GRV98PA routine,
38311C adapted to define interpolation table as DATA statements
38312C
38313C (R.Engel, 09/98)
38314C
38315C CAUTION: this is a version with gluon shadowing corrections
38316C (R.Engel, 09/99)
38317C
38318C
38319C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
38320C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
38321C
38322C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
38323C DS = d(bar), SS = s = s(bar), GL = gluon.
38324C Always x times the distribution is returned.
38325C
38326C******************************************************i****************
38327 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
38328 SAVE
38329
38330C input/output channels
38331 INTEGER LI,LO
38332 COMMON /POINOU/ LI,LO
38333
38334 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
38335 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
38336 1 XSF(NX,NQ), XGF(NX,NQ),
38337 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
38338
38339 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
38340 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
38341
38342 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
38343 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
38344 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
38345 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
38346 EQUIVALENCE (XSF(1,1),XSF_L(1))
38347 EQUIVALENCE (XGF(1,1),XGF_L(1))
38348
38349*#################### data statements for shadowed LO PDF ##############
38350C ... deleted ...
38351*#######################################################################
38352
38353 X = Xinp
38354*...CHECK OF X AND Q2 VALUES :
38355 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
38356* WRITE(LO,91) X
38357 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
38358 X = 0.99D-9
38359* STOP
38360 ENDIF
38361
38362 Q2 = Q2inp
38363 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
38364* WRITE(LO,92) Q2
38365 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
38366 Q2 = 0.99E6
38367* STOP
38368 ENDIF
38369
38370*
38371*...INTERPOLATION :
38372 NA(1) = NX
38373 NA(2) = NQ
38374 XT(1) = DLOG(X)
38375 XT(2) = DLOG(Q2)
38376 X1 = 1.- X
38377 XV = X**0.5
38378 XS = X**(-0.2)
38379 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
38380 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
38381 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
38382 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
38383 US = 0.5 * (UD - DE)
38384 DS = 0.5 * (UD + DE)
38385 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
38386 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
38387
38388 END
38389
38390*$ CREATE PHO_DOR94LO.FOR
38391*COPY PHO_DOR94LO
38392CDECK ID>, PHO_DOR94LO
38393* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38394* *
38395* G R V - P R O T O N - P A R A M E T R I Z A T I O N S *
38396* *
38397* 1994 UPDATE *
38398* *
38399* FOR A DETAILED EXPLANATION SEE *
38400* M. GLUECK, E.REYA, A.VOGT : *
38401* DO-TH 94/24 = DESY 94-206 *
38402* (TO APPEAR IN Z. PHYS. C) *
38403* *
38404* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
38405* Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
38406* X BETWEEN 1.E-5 AND 1. *
38407* LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
38408* IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
38409* *
38410* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
38411* M(C) = 1.5, M(B) = 4.5 *
38412* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
38413* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38414* LAMBDA(5) = 0.153, *
38415* NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38416* LAMBDA(5) = 0.131. *
38417* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
38418* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
38419* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
38420* IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
38421* GRV PARAMETRIZATION. *
38422* *
38423* NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
38424* (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
38425* THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
38426* *
38427* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38428*
38429*...INPUT PARAMETERS :
38430*
38431* X = MOMENTUM FRACTION
38432* Q2 = SCALE Q**2 IN GEV**2
38433*
38434*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
38435*
38436* UV = U(VAL) = U - U(BAR)
38437* DV = D(VAL) = D - D(BAR)
38438* DEL = D(BAR) - U(BAR)
38439* UDB = U(BAR) + D(BAR)
38440* SB = S = S(BAR)
38441* GL = GLUON
38442*
38443*...LO PARAMETRIZATION :
38444*
38445 SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38446 IMPLICIT DOUBLE PRECISION (A - Z)
38447 SAVE
38448
38449 MU2 = 0.23
38450 LAM2 = 0.2322 * 0.2322
38451 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38452 DS = SQRT (S)
38453 S2 = S * S
38454 S3 = S2 * S
38455*...UV :
38456 NU = 2.284 + 0.802 * S + 0.055 * S2
38457 AKU = 0.590 - 0.024 * S
38458 BKU = 0.131 + 0.063 * S
38459 AU = -0.449 - 0.138 * S - 0.076 * S2
38460 BU = 0.213 + 2.669 * S - 0.728 * S2
38461 CU = 8.854 - 9.135 * S + 1.979 * S2
38462 DU = 2.997 + 0.753 * S - 0.076 * S2
38463 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38464*...DV :
38465 ND = 0.371 + 0.083 * S + 0.039 * S2
38466 AKD = 0.376
38467 BKD = 0.486 + 0.062 * S
38468 AD = -0.509 + 3.310 * S - 1.248 * S2
38469 BD = 12.41 - 10.52 * S + 2.267 * S2
38470 CD = 6.373 - 6.208 * S + 1.418 * S2
38471 DD = 3.691 + 0.799 * S - 0.071 * S2
38472 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38473*...DEL :
38474 NE = 0.082 + 0.014 * S + 0.008 * S2
38475 AKE = 0.409 - 0.005 * S
38476 BKE = 0.799 + 0.071 * S
38477 AE = -38.07 + 36.13 * S - 0.656 * S2
38478 BE = 90.31 - 74.15 * S + 7.645 * S2
38479 CE = 0.0
38480 DE = 7.486 + 1.217 * S - 0.159 * S2
38481 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38482*...UDB :
38483 ALX = 1.451
38484 BEX = 0.271
38485 AKX = 0.410 - 0.232 * S
38486 BKX = 0.534 - 0.457 * S
38487 AGX = 0.890 - 0.140 * S
38488 BGX = -0.981
38489 CX = 0.320 + 0.683 * S
38490 DX = 4.752 + 1.164 * S + 0.286 * S2
38491 EX = 4.119 + 1.713 * S
38492 ESX = 0.682 + 2.978 * S
38493 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38494*...SB :
38495 ALS = 0.914
38496 BES = 0.577
38497 AKS = 1.798 - 0.596 * S
38498 AS = -5.548 + 3.669 * DS - 0.616 * S
38499 BS = 18.92 - 16.73 * DS + 5.168 * S
38500 DST = 6.379 - 0.350 * S + 0.142 * S2
38501 EST = 3.981 + 1.638 * S
38502 ESS = 6.402
38503 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38504*...GL :
38505 ALG = 0.524
38506 BEG = 1.088
38507 AKG = 1.742 - 0.930 * S
38508 BKG = - 0.399 * S2
38509 AG = 7.486 - 2.185 * S
38510 BG = 16.69 - 22.74 * S + 5.779 * S2
38511 CG = -25.59 + 29.71 * S - 7.296 * S2
38512 DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
38513 EG = 0.807 + 2.005 * S
38514 ESG = 3.841 + 0.316 * S
38515 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38516
38517 END
38518
38519*
38520*...NLO PARAMETRIZATION (MS(BAR)) :
38521*
38522*$ CREATE PHO_DOR94HO.FOR
38523*COPY PHO_DOR94HO
38524CDECK ID>, PHO_DOR94HO
38525 SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38526 IMPLICIT DOUBLE PRECISION (A - Z)
38527 SAVE
38528
38529 MU2 = 0.34
38530 LAM2 = 0.248 * 0.248
38531 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38532 DS = SQRT (S)
38533 S2 = S * S
38534 S3 = S2 * S
38535*...UV :
38536 NU = 1.304 + 0.863 * S
38537 AKU = 0.558 - 0.020 * S
38538 BKU = 0.183 * S
38539 AU = -0.113 + 0.283 * S - 0.321 * S2
38540 BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38541 CU = 7.771 - 10.09 * S + 2.630 * S2
38542 DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38543 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38544*...DV :
38545 ND = 0.102 - 0.017 * S + 0.005 * S2
38546 AKD = 0.270 - 0.019 * S
38547 BKD = 0.260
38548 AD = 2.393 + 6.228 * S - 0.881 * S2
38549 BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38550 CD = 17.83 - 53.47 * S + 21.24 * S2
38551 DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38552 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38553*...DEL :
38554 NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38555 AKE = 0.409 - 0.007 * S
38556 BKE = 0.782 + 0.082 * S
38557 AE = -29.65 + 26.49 * S + 5.429 * S2
38558 BE = 90.20 - 74.97 * S + 4.526 * S2
38559 CE = 0.0
38560 DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38561 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38562*...UDB :
38563 ALX = 0.877
38564 BEX = 0.561
38565 AKX = 0.275
38566 BKX = 0.0
38567 AGX = 0.997
38568 BGX = 3.210 - 1.866 * S
38569 CX = 7.300
38570 DX = 9.010 + 0.896 * DS + 0.222 * S2
38571 EX = 3.077 + 1.446 * S
38572 ESX = 3.173 - 2.445 * DS + 2.207 * S
38573 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38574*...SB :
38575 ALS = 0.756
38576 BES = 0.216
38577 AKS = 1.690 + 0.650 * DS - 0.922 * S
38578 AS = -4.329 + 1.131 * S
38579 BS = 9.568 - 1.744 * S
38580 DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38581 EST = 3.031 + 1.639 * S
38582 ESS = 5.837 + 0.815 * S
38583 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38584*...GL :
38585 ALG = 1.014
38586 BEG = 1.738
38587 AKG = 1.724 + 0.157 * S
38588 BKG = 0.800 + 1.016 * S
38589 AG = 7.517 - 2.547 * S
38590 BG = 34.09 - 52.21 * DS + 17.47 * S
38591 CG = 4.039 + 1.491 * S
38592 DG = 3.404 + 0.830 * S
38593 EG = -1.112 + 3.438 * S - 0.302 * S2
38594 ESG = 3.256 - 0.436 * S
38595 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38596
38597 END
38598
38599*$ CREATE PHO_DOR94DI.FOR
38600*COPY PHO_DOR94DI
38601CDECK ID>, PHO_DOR94DI
38602*
38603*...NLO PARAMETRIZATION (DIS) :
38604*
38605 SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38606 IMPLICIT DOUBLE PRECISION (A - Z)
38607 SAVE
38608
38609 MU2 = 0.34
38610 LAM2 = 0.248 * 0.248
38611 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38612 DS = SQRT (S)
38613 S2 = S * S
38614 S3 = S2 * S
38615*...UV :
38616 NU = 2.484 + 0.116 * S + 0.093 * S2
38617 AKU = 0.563 - 0.025 * S
38618 BKU = 0.054 + 0.154 * S
38619 AU = -0.326 - 0.058 * S - 0.135 * S2
38620 BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38621 CU = 11.52 - 12.99 * S + 3.161 * S2
38622 DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38623 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38624*...DV :
38625 ND = 0.156 - 0.017 * S
38626 AKD = 0.299 - 0.022 * S
38627 BKD = 0.259 - 0.015 * S
38628 AD = 3.445 + 1.278 * S + 0.326 * S2
38629 BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38630 CD = 55.45 - 69.92 * S + 20.78 * S2
38631 DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38632 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38633*...DEL :
38634 NE = 0.099 + 0.019 * S + 0.002 * S2
38635 AKE = 0.419 - 0.013 * S
38636 BKE = 1.064 - 0.038 * S
38637 AE = -44.00 + 98.70 * S - 14.79 * S2
38638 BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38639 CE = 84.57 - 108.8 * S + 31.52 * S2
38640 DE = 7.469 + 2.480 * S - 0.866 * S2
38641 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38642*...UDB :
38643 ALX = 1.215
38644 BEX = 0.466
38645 AKX = 0.326 + 0.150 * S
38646 BKX = 0.956 + 0.405 * S
38647 AGX = 0.272
38648 BGX = 3.794 - 2.359 * DS
38649 CX = 2.014
38650 DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38651 EX = 3.049 + 1.597 * S
38652 ESX = 4.396 - 4.594 * DS + 3.268 * S
38653 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38654*...SB :
38655 ALS = 0.175
38656 BES = 0.344
38657 AKS = 1.415 - 0.641 * DS
38658 AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
38659 BS = 5.617 + 5.709 * DS - 3.972 * S
38660 DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
38661 EST = 4.546 + 0.372 * S2
38662 ESS = 5.053 - 1.070 * S + 0.805 * S2
38663 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38664*...GL :
38665 ALG = 1.258
38666 BEG = 1.846
38667 AKG = 2.423
38668 BKG = 2.427 + 1.311 * S - 0.153 * S2
38669 AG = 25.09 - 7.935 * S
38670 BG = -14.84 - 124.3 * DS + 72.18 * S
38671 CG = 590.3 - 173.8 * S
38672 DG = 5.196 + 1.857 * S
38673 EG = -1.648 + 3.988 * S - 0.432 * S2
38674 ESG = 3.232 - 0.542 * S
38675 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38676
38677 END
38678
38679*
38680*...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38681*
38682*$ CREATE PHO_DOR94FV.FOR
38683*COPY PHO_DOR94FV
38684CDECK ID>, PHO_DOR94FV
38685 DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38686 IMPLICIT DOUBLE PRECISION (A - Z)
38687 SAVE
38688
38689 DX = SQRT (X)
38690 PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38691
38692 END
38693
38694*$ CREATE PHO_DOR94FW.FOR
38695*COPY PHO_DOR94FW
38696CDECK ID>, PHO_DOR94FW
38697 DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38698 & A,B,C,D,E,ES)
38699 IMPLICIT DOUBLE PRECISION (A - Z)
38700 SAVE
38701
38702 LX = LOG (1./X)
38703 PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38704 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38705
38706 END
38707
38708*$ CREATE PHO_DOR94FS.FOR
38709*COPY PHO_DOR94FS
38710CDECK ID>, PHO_DOR94FS
38711 DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38712 IMPLICIT DOUBLE PRECISION (A - Z)
38713 SAVE
38714
38715 DX = SQRT (X)
38716 LX = LOG (1./X)
38717 PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38718 1 * DEXP (-E + SQRT (ES * S**BE * LX))
38719
38720 END
38721
38722*$ CREATE PHO_DOR92LO.FOR
38723*COPY PHO_DOR92LO
38724CDECK ID>, PHO_DOR92LO
38725*
38726*
38727* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38728* *
38729* G R V - P R O T O N - P A R A M E T R I Z A T I O N S *
38730* *
38731* FOR A DETAILED EXPLANATION SEE : *
38732* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
38733* *
38734* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38735* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38736* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38737* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38738* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38739* *
38740* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38741* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38742* *
38743* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38744* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38745* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38746* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38747* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38748* *
38749* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38750* *
38751* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38752C
38753 SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38754 IMPLICIT DOUBLE PRECISION (A - Z)
38755 SAVE
38756
38757 MU2 = 0.25
38758 LAM2 = 0.232 * 0.232
38759 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38760 S2 = S * S
38761 S3 = S2 * S
38762C...X * (UV + DV) :
38763 NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38764 AKUD = 0.326
38765 AGUD = -1.97 + 6.74 * S - 1.96 * S2
38766 BUD = 24.4 - 20.7 * S + 4.08 * S2
38767 DUD = 2.86 + 0.70 * S - 0.02 * S2
38768 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38769C...X * DV :
38770 ND = 0.579 + 0.283 * S + 0.047 * S2
38771 AKD = 0.523 - 0.015 * S
38772 AGD = 2.22 - 0.59 * S - 0.27 * S2
38773 BD = 5.95 - 6.19 * S + 1.55 * S2
38774 DD = 3.57 + 0.94 * S - 0.16 * S2
38775 DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38776C...X * G :
38777 ALG = 0.558
38778 BEG = 1.218
38779 AKG = 1.00 - 0.17 * S
38780 BKG = 0.0
38781 AGG = 0.0 + 4.879 * S - 1.383 * S2
38782 BGG = 25.92 - 28.97 * S + 5.596 * S2
38783 CG = -25.69 + 23.68 * S - 1.975 * S2
38784 DG = 2.537 + 1.718 * S + 0.353 * S2
38785 EG = 0.595 + 2.138 * S
38786 ESG = 4.066
38787 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38788C...X * UBAR = X * DBAR :
38789 ALU = 1.396
38790 BEU = 1.331
38791 AKU = 0.412 - 0.171 * S
38792 BKU = 0.566 - 0.496 * S
38793 AGU = 0.363
38794 BGU = -1.196
38795 CU = 1.029 + 1.785 * S - 0.459 * S2
38796 DU = 4.696 + 2.109 * S
38797 EU = 3.838 + 1.944 * S
38798 ESU = 2.845
38799 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38800C...X * SBAR = X * S :
38801 SS = 0.0
38802 ALS = 0.803
38803 BES = 0.563
38804 AKS = 2.082 - 0.577 * S
38805 AGS = -3.055 + 1.024 * S ** 0.67
38806 BS = 27.4 - 20.0 * S ** 0.154
38807 DS = 6.22
38808 EST = 4.33 + 1.408 * S
38809 ESS = 8.27 - 0.437 * S
38810 SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38811C...X * CBAR = X * C :
38812 SC = 0.888
38813 ALC = 1.01
38814 BEC = 0.37
38815 AKC = 0.0
38816 AGC = 0.0
38817 BC = 4.24 - 0.804 * S
38818 DC = 3.46 + 1.076 * S
38819 EC = 4.61 + 1.490 * S
38820 ESC = 2.555 + 1.961 * S
38821 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38822C...X * BBAR = X * B :
38823 SBO = 1.351
38824 ALB = 1.00
38825 BEB = 0.51
38826 AKB = 0.0
38827 AGB = 0.0
38828 BBO = 1.848
38829 DB = 2.929 + 1.396 * S
38830 EB = 4.71 + 1.514 * S
38831 ESB = 4.02 + 1.239 * S
38832 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38833
38834 END
38835
38836*$ CREATE PHO_DOR92HO.FOR
38837*COPY PHO_DOR92HO
38838CDECK ID>, PHO_DOR92HO
38839 SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38840 IMPLICIT DOUBLE PRECISION (A - Z)
38841 SAVE
38842
38843 MU2 = 0.3
38844 LAM2 = 0.248 * 0.248
38845 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38846 DS = SQRT (S)
38847 S2 = S * S
38848 S3 = S2 * S
38849C...X * (UV + DV) :
38850 NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38851 AKUD = 0.285
38852 AGUD = -2.28 + 15.73 * S - 4.58 * S2
38853 BUD = 56.7 - 53.6 * S + 11.21 * S2
38854 DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
38855 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38856C...X * DV :
38857 ND = 0.459 + 0.315 * DS + 0.515 * S
38858 AKD = 0.624 - 0.031 * S
38859 AGD = 8.13 - 6.77 * DS + 0.46 * S
38860 BD = 6.59 - 12.83 * DS + 5.65 * S
38861 DD = 3.98 + 1.04 * S - 0.34 * S2
38862 DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38863C...X * G :
38864 ALG = 1.128
38865 BEG = 1.575
38866 AKG = 0.323 + 1.653 * S
38867 BKG = 0.811 + 2.044 * S
38868 AGG = 0.0 + 1.963 * S - 0.519 * S2
38869 BGG = 0.078 + 6.24 * S
38870 CG = 30.77 - 24.19 * S
38871 DG = 3.188 + 0.720 * S
38872 EG = -0.881 + 2.687 * S
38873 ESG = 2.466
38874 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38875C...X * UBAR = X * DBAR :
38876 ALU = 0.594
38877 BEU = 0.614
38878 AKU = 0.636 - 0.084 * S
38879 BKU = 0.0
38880 AGU = 1.121 - 0.193 * S
38881 BGU = 0.751 - 0.785 * S
38882 CU = 8.57 - 1.763 * S
38883 DU = 10.22 + 0.668 * S
38884 EU = 3.784 + 1.280 * S
38885 ESU = 1.808 + 0.980 * S
38886 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38887C...X * SBAR = X * S :
38888 SS = 0.0
38889 ALS = 0.756
38890 BES = 0.101
38891 AKS = 2.942 - 1.016 * S
38892 AGS = -4.60 + 1.167 * S
38893 BS = 9.31 - 1.324 * S
38894 DS = 11.49 - 1.198 * S + 0.053 * S2
38895 EST = 2.630 + 1.729 * S
38896 ESS = 8.12
38897 SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38898C...X * CBAR = X * C :
38899 SC = 0.820
38900 ALC = 0.98
38901 BEC = 0.0
38902 AKC = -0.625 - 0.523 * S
38903 AGC = 0.0
38904 BC = 1.896 + 1.616 * S
38905 DC = 4.12 + 0.683 * S
38906 EC = 4.36 + 1.328 * S
38907 ESC = 0.677 + 0.679 * S
38908 CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38909C...X * BBAR = X * B :
38910 SBO = 1.297
38911 ALB = 0.99
38912 BEB = 0.0
38913 AKB = 0.0 - 0.193 * S
38914 AGB = 0.0
38915 BBO = 0.0
38916 DB = 3.447 + 0.927 * S
38917 EB = 4.68 + 1.259 * S
38918 ESB = 1.892 + 2.199 * S
38919 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38920
38921 END
38922
38923*$ CREATE PHO_DOR92FV.FOR
38924*COPY PHO_DOR92FV
38925CDECK ID>, PHO_DOR92FV
38926 DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38927 IMPLICIT DOUBLE PRECISION (A - Z)
38928 SAVE
38929 DX = SQRT (X)
38930 PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38931
38932 END
38933
38934*$ CREATE PHO_DOR92FW.FOR
38935*COPY PHO_DOR92FW
38936CDECK ID>, PHO_DOR92FW
38937 DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38938 & AL,BE,AK,BK,AG,BG,C,D,E,ES)
38939 IMPLICIT DOUBLE PRECISION (A - Z)
38940 SAVE
38941 LX = LOG (1./X)
38942 PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38943 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38944
38945 END
38946
38947*$ CREATE PHO_DOR92FS.FOR
38948*COPY PHO_DOR92FS
38949CDECK ID>, PHO_DOR92FS
38950 DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38951 IMPLICIT DOUBLE PRECISION (A - Z)
38952 SAVE
38953
38954 DX = SQRT (X)
38955 LX = LOG (1./X)
38956 IF (S .LE. ST) THEN
38957 PHO_DOR92FS = 0.D0
38958 ELSE
38959 PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38960 1 * EXP (-E + SQRT (ES * S**BE * LX))
38961 END IF
38962
38963 END
38964
38965*$ CREATE PHO_DORPLO.FOR
38966*COPY PHO_DORPLO
38967CDECK ID>, PHO_DORPLO
38968*
38969* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38970* *
38971* G R V - P I O N - P A R A M E T R I Z A T I O N S *
38972* *
38973* FOR A DETAILED EXPLANATION SEE : *
38974* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
38975* *
38976* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38977* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38978* / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38979* REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38980* LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38981* *
38982* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38983* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38984* *
38985* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38986* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38987* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38988* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38989* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38990* *
38991* HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38992* *
38993* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38994C
38995 SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38996 IMPLICIT DOUBLE PRECISION (A - Z)
38997 SAVE
38998
38999 MU2 = 0.25
39000 LAM2 = 0.232 * 0.232
39001 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39002 DS = SQRT (S)
39003 S2 = S * S
39004C...X * VALENCE :
39005 NV = 0.519 + 0.180 * S - 0.011 * S2
39006 AKV = 0.499 - 0.027 * S
39007 AGV = 0.381 - 0.419 * S
39008 DV = 0.367 + 0.563 * S
39009 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
39010C...X * GLUON :
39011 ALG = 0.599
39012 BEG = 1.263
39013 AKG = 0.482 + 0.341 * DS
39014 BKG = 0.0
39015 AGG = 0.678 + 0.877 * S - 0.175 * S2
39016 BGG = 0.338 - 1.597 * S
39017 CG = 0.0 - 0.233 * S + 0.406 * S2
39018 DG = 0.390 + 1.053 * S
39019 EG = 0.618 + 2.070 * S
39020 ESG = 3.676
39021 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
39022C...X * QBAR (SU(3)-SYMMETRIC SEA) :
39023 SL = 0.0
39024 ALS = 0.55
39025 BES = 0.56
39026 AKS = 2.538 - 0.763 * S
39027 AGS = -0.748
39028 BS = 0.313 + 0.935 * S
39029 DS = 3.359
39030 EST = 4.433 + 1.301 * S
39031 ESS = 9.30 - 0.887 * S
39032 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
39033C...X * CBAR = X * C :
39034 SC = 0.888
39035 ALC = 1.02
39036 BEC = 0.39
39037 AKC = 0.0
39038 AGC = 0.0
39039 BC = 1.008
39040 DC = 1.208 + 0.771 * S
39041 EC = 4.40 + 1.493 * S
39042 ESC = 2.032 + 1.901 * S
39043 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
39044C...X * BBAR = X * B :
39045 SBO = 1.351
39046 ALB = 1.03
39047 BEB = 0.39
39048 AKB = 0.0
39049 AGB = 0.0
39050 BBO = 0.0
39051 DB = 0.697 + 0.855 * S
39052 EB = 4.51 + 1.490 * S
39053 ESB = 3.056 + 1.694 * S
39054 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
39055
39056 END
39057
39058*$ CREATE PHO_DORPHO.FOR
39059*COPY PHO_DORPHO
39060CDECK ID>, PHO_DORPHO
39061 SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
39062 IMPLICIT DOUBLE PRECISION (A - Z)
39063 SAVE
39064
39065 MU2 = 0.3
39066 LAM2 = 0.248 * 0.248
39067 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39068 DS = SQRT (S)
39069 S2 = S * S
39070C...X * VALENCE :
39071 NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
39072 AKV = 0.505 - 0.033 * S
39073 AGV = 0.748 - 0.669 * DS - 0.133 * S
39074 DV = 0.365 + 0.197 * DS + 0.394 * S
39075 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
39076C...X * GLUON :
39077 ALG = 1.096
39078 BEG = 1.371
39079 AKG = 0.437 - 0.689 * DS
39080 BKG = -0.631
39081 AGG = 1.324 - 0.441 * DS - 0.130 * S
39082 BGG = -0.955 + 0.259 * S
39083 CG = 1.075 - 0.302 * S
39084 DG = 1.158 + 1.229 * S
39085 EG = 0.0 + 2.510 * S
39086 ESG = 2.604 + 0.165 * S
39087 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
39088C...X * QBAR (SU(3)-SYMMETRIC SEA) :
39089 SL = 0.0
39090 ALS = 0.85
39091 BES = 0.96
39092 AKS = -0.350 + 0.806 * S
39093 AGS = -1.663
39094 BS = 3.148
39095 DS = 2.273 + 1.438 * S
39096 EST = 3.214 + 1.545 * S
39097 ESS = 1.341 + 1.938 * S
39098 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
39099C...X * CBAR = X * C :
39100 SC = 0.820
39101 ALC = 0.98
39102 BEC = 0.0
39103 AKC = 0.0 - 0.457 * S
39104 AGC = 0.0
39105 BC = -1.00 + 1.40 * S
39106 DC = 1.318 + 0.584 * S
39107 EC = 4.45 + 1.235 * S
39108 ESC = 1.496 + 1.010 * S
39109 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
39110C...X * BBAR = X * B :
39111 SBO = 1.297
39112 ALB = 0.99
39113 BEB = 0.0
39114 AKB = 0.0 - 0.172 * S
39115 AGB = 0.0
39116 BBO = 0.0
39117 DB = 1.447 + 0.485 * S
39118 EB = 4.79 + 1.164 * S
39119 ESB = 1.724 + 2.121 * S
39120 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
39121
39122 END
39123
39124*$ CREATE PHO_DORFVP.FOR
39125*COPY PHO_DORFVP
39126CDECK ID>, PHO_DORFVP
39127 DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
39128 IMPLICIT DOUBLE PRECISION (A - Z)
39129 SAVE
39130
39131 DX = SQRT (X)
39132 PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
39133
39134 END
39135
39136*$ CREATE PHO_DORFGP.FOR
39137*COPY PHO_DORFGP
39138CDECK ID>, PHO_DORFGP
39139 DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
39140 & BG,C,D,E,ES)
39141 IMPLICIT DOUBLE PRECISION (A - Z)
39142 SAVE
39143
39144 DX = SQRT (X)
39145 LX = LOG (1./X)
39146 PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
39147 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39148
39149 END
39150
39151*$ CREATE PHO_DORFQP.FOR
39152*COPY PHO_DORFQP
39153CDECK ID>, PHO_DORFQP
39154 DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
39155 IMPLICIT DOUBLE PRECISION (A - Z)
39156 SAVE
39157
39158 DX = SQRT (X)
39159 LX = LOG (1./X)
39160 IF (S .LE. ST) THEN
39161 PHO_DORFQP = 0.0
39162 ELSE
39163 PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
39164 1 * EXP (-E + SQRT (ES * S**BE * LX))
39165 END IF
39166
39167 END
39168
39169*$ CREATE PHO_DORGLO.FOR
39170*COPY PHO_DORGLO
39171CDECK ID>, PHO_DORGLO
39172* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39173* *
39174* G R V - P H O T O N - P A R A M E T R I Z A T I O N S *
39175* *
39176* FOR A DETAILED EXPLANATION SEE : *
39177* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
39178* *
39179* THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
39180* *
39181* THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
39182* FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
39183* / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
39184* *
39185* HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
39186* M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
39187* *
39188* CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
39189* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
39190* LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
39191* HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
39192* LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
39193* *
39194* HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
39195* M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
39196* *
39197* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39198C
39199 SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
39200 IMPLICIT DOUBLE PRECISION (A - Z)
39201 SAVE
39202
39203 MU2 = 0.25
39204 LAM2 = 0.232 * 0.232
39205 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39206 SS = SQRT (S)
39207 S2 = S * S
39208C...X * U = X * UBAR :
39209 AL = 1.717
39210 BE = 0.641
39211 AK = 0.500 - 0.176 * S
39212 BK = 15.00 - 5.687 * SS - 0.552 * S2
39213 AG = 0.235 + 0.046 * SS
39214 BG = 0.082 - 0.051 * S + 0.168 * S2
39215 C = 0.0 + 0.459 * S
39216 D = 0.354 - 0.061 * S
39217 E = 4.899 + 1.678 * S
39218 ES = 2.046 + 1.389 * S
39219 UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39220C...X * D = X * DBAR :
39221 AL = 1.549
39222 BE = 0.782
39223 AK = 0.496 + 0.026 * S
39224 BK = 0.685 - 0.580 * SS + 0.608 * S2
39225 AG = 0.233 + 0.302 * S
39226 BG = 0.0 - 0.818 * S + 0.198 * S2
39227 C = 0.114 + 0.154 * S
39228 D = 0.405 - 0.195 * S + 0.046 * S2
39229 E = 4.807 + 1.226 * S
39230 ES = 2.166 + 0.664 * S
39231 DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39232C...X * G :
39233 AL = 0.676
39234 BE = 1.089
39235 AK = 0.462 - 0.524 * SS
39236 BK = 5.451 - 0.804 * S2
39237 AG = 0.535 - 0.504 * SS + 0.288 * S2
39238 BG = 0.364 - 0.520 * S
39239 C = -0.323 + 0.115 * S2
39240 D = 0.233 + 0.790 * S - 0.139 * S2
39241 E = 0.893 + 1.968 * S
39242 ES = 3.432 + 0.392 * S
39243 GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39244C...X * S = X * SBAR :
39245 SF = 0.0
39246 AL = 1.609
39247 BE = 0.962
39248 AK = 0.470 - 0.099 * S2
39249 BK = 3.246
39250 AG = 0.121 - 0.068 * SS
39251 BG = -0.090 + 0.074 * S
39252 C = 0.062 + 0.034 * S
39253 D = 0.0 + 0.226 * S - 0.060 * S2
39254 E = 4.288 + 1.707 * S
39255 ES = 2.122 + 0.656 * S
39256 SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39257C...X * C = X * CBAR :
39258 SF = 0.888
39259 AL = 0.970
39260 BE = 0.545
39261 AK = 1.254 - 0.251 * S
39262 BK = 3.932 - 0.327 * S2
39263 AG = 0.658 + 0.202 * S
39264 BG = -0.699
39265 C = 0.965
39266 D = 0.0 + 0.141 * S - 0.027 * S2
39267 E = 4.911 + 0.969 * S
39268 ES = 2.796 + 0.952 * S
39269 CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39270C...X * B = X * BBAR :
39271 SF = 1.351
39272 AL = 1.016
39273 BE = 0.338
39274 AK = 1.961 - 0.370 * S
39275 BK = 0.923 + 0.119 * S
39276 AG = 0.815 + 0.207 * S
39277 BG = -2.275
39278 C = 1.480
39279 D = -0.223 + 0.173 * S
39280 E = 5.426 + 0.623 * S
39281 ES = 3.819 + 0.901 * S
39282 BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39283
39284 END
39285
39286*$ CREATE PHO_DORGHO.FOR
39287*COPY PHO_DORGHO
39288CDECK ID>, PHO_DORGHO
39289 SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
39290 IMPLICIT DOUBLE PRECISION (A - Z)
39291 SAVE
39292
39293 MU2 = 0.3
39294 LAM2 = 0.248 * 0.248
39295 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39296 SS = SQRT (S)
39297 S2 = S * S
39298C...X * U = X * UBAR :
39299 AL = 0.583
39300 BE = 0.688
39301 AK = 0.449 - 0.025 * S - 0.071 * S2
39302 BK = 5.060 - 1.116 * SS
39303 AG = 0.103
39304 BG = 0.319 + 0.422 * S
39305 C = 1.508 + 4.792 * S - 1.963 * S2
39306 D = 1.075 + 0.222 * SS - 0.193 * S2
39307 E = 4.147 + 1.131 * S
39308 ES = 1.661 + 0.874 * S
39309 UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39310C...X * D = X * DBAR :
39311 AL = 0.591
39312 BE = 0.698
39313 AK = 0.442 - 0.132 * S - 0.058 * S2
39314 BK = 5.437 - 1.916 * SS
39315 AG = 0.099
39316 BG = 0.311 - 0.059 * S
39317 C = 0.800 + 0.078 * S - 0.100 * S2
39318 D = 0.862 + 0.294 * SS - 0.184 * S2
39319 E = 4.202 + 1.352 * S
39320 ES = 1.841 + 0.990 * S
39321 DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39322C...X * G :
39323 AL = 1.161
39324 BE = 1.591
39325 AK = 0.530 - 0.742 * SS + 0.025 * S2
39326 BK = 5.662
39327 AG = 0.533 - 0.281 * SS + 0.218 * S2
39328 BG = 0.025 - 0.518 * S + 0.156 * S2
39329 C = -0.282 + 0.209 * S2
39330 D = 0.107 + 1.058 * S - 0.218 * S2
39331 E = 0.0 + 2.704 * S
39332 ES = 3.071 - 0.378 * S
39333 GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39334C...X * S = X * SBAR :
39335 SF = 0.0
39336 AL = 0.635
39337 BE = 0.456
39338 AK = 1.770 - 0.735 * SS - 0.079 * S2
39339 BK = 3.832
39340 AG = 0.084 - 0.023 * S
39341 BG = 0.136
39342 C = 2.119 - 0.942 * S + 0.063 * S2
39343 D = 1.271 + 0.076 * S - 0.190 * S2
39344 E = 4.604 + 0.737 * S
39345 ES = 1.641 + 0.976 * S
39346 SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39347C...X * C = X * CBAR :
39348 SF = 0.820
39349 AL = 0.926
39350 BE = 0.152
39351 AK = 1.142 - 0.175 * S
39352 BK = 3.276
39353 AG = 0.504 + 0.317 * S
39354 BG = -0.433
39355 C = 3.334
39356 D = 0.398 + 0.326 * S - 0.107 * S2
39357 E = 5.493 + 0.408 * S
39358 ES = 2.426 + 1.277 * S
39359 CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39360C...X * B = X * BBAR :
39361 SF = 1.297
39362 AL = 0.969
39363 BE = 0.266
39364 AK = 1.953 - 0.391 * S
39365 BK = 1.657 - 0.161 * S
39366 AG = 1.076 + 0.034 * S
39367 BG = -2.015
39368 C = 1.662
39369 D = 0.353 + 0.016 * S
39370 E = 5.713 + 0.249 * S
39371 ES = 3.456 + 0.673 * S
39372 BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39373
39374 END
39375
39376*$ CREATE PHO_DORGH0.FOR
39377*COPY PHO_DORGH0
39378CDECK ID>, PHO_DORGH0
39379 SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
39380 IMPLICIT DOUBLE PRECISION (A - Z)
39381 SAVE
39382
39383 MU2 = 0.3
39384 LAM2 = 0.248 * 0.248
39385 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39386 SS = SQRT (S)
39387 S2 = S * S
39388C...X * U = X * UBAR :
39389 AL = 1.447
39390 BE = 0.848
39391 AK = 0.527 + 0.200 * S - 0.107 * S2
39392 BK = 7.106 - 0.310 * SS - 0.786 * S2
39393 AG = 0.197 + 0.533 * S
39394 BG = 0.062 - 0.398 * S + 0.109 * S2
39395 C = 0.755 * S - 0.112 * S2
39396 D = 0.318 - 0.059 * S
39397 E = 4.225 + 1.708 * S
39398 ES = 1.752 + 0.866 * S
39399 U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39400C...X * D = X * DBAR :
39401 AL = 1.424
39402 BE = 0.770
39403 AK = 0.500 + 0.067 * SS - 0.055 * S2
39404 BK = 0.376 - 0.453 * SS + 0.405 * S2
39405 AG = 0.156 + 0.184 * S
39406 BG = 0.0 - 0.528 * S + 0.146 * S2
39407 C = 0.121 + 0.092 * S
39408 D = 0.379 - 0.301 * S + 0.081 * S2
39409 E = 4.346 + 1.638 * S
39410 ES = 1.645 + 1.016 * S
39411 D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39412C...X * G :
39413 AL = 0.661
39414 BE = 0.793
39415 AK = 0.537 - 0.600 * SS
39416 BK = 6.389 - 0.953 * S2
39417 AG = 0.558 - 0.383 * SS + 0.261 * S2
39418 BG = 0.0 - 0.305 * S
39419 C = -0.222 + 0.078 * S2
39420 D = 0.153 + 0.978 * S - 0.209 * S2
39421 E = 1.429 + 1.772 * S
39422 ES = 3.331 + 0.806 * S
39423 G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39424C...X * S = X * SBAR :
39425 SF = 0.0
39426 AL = 1.578
39427 BE = 0.863
39428 AK = 0.622 + 0.332 * S - 0.300 * S2
39429 BK = 2.469
39430 AG = 0.211 - 0.064 * SS - 0.018 * S2
39431 BG = -0.215 + 0.122 * S
39432 C = 0.153
39433 D = 0.0 + 0.253 * S - 0.081 * S2
39434 E = 3.990 + 2.014 * S
39435 ES = 1.720 + 0.986 * S
39436 S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39437C...X * C = X * CBAR :
39438 SF = 0.820
39439 AL = 0.929
39440 BE = 0.381
39441 AK = 1.228 - 0.231 * S
39442 BK = 3.806 - 0.337 * S2
39443 AG = 0.932 + 0.150 * S
39444 BG = -0.906
39445 C = 1.133
39446 D = 0.0 + 0.138 * S - 0.028 * S2
39447 E = 5.588 + 0.628 * S
39448 ES = 2.665 + 1.054 * S
39449 C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39450C...X * B = X * BBAR :
39451 SF = 1.297
39452 AL = 0.970
39453 BE = 0.207
39454 AK = 1.719 - 0.292 * S
39455 BK = 0.928 + 0.096 * S
39456 AG = 0.845 + 0.178 * S
39457 BG = -2.310
39458 C = 1.558
39459 D = -0.191 + 0.151 * S
39460 E = 6.089 + 0.282 * S
39461 ES = 3.379 + 1.062 * S
39462 B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39463
39464 END
39465
39466*$ CREATE PHO_DORGF.FOR
39467*COPY PHO_DORGF
39468CDECK ID>, PHO_DORGF
39469 DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39470 & AG,BG,C,D,E,ES)
39471 IMPLICIT DOUBLE PRECISION (A - Z)
39472 SAVE
39473
39474 SX = SQRT (X)
39475 LX = LOG (1./X)
39476 PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
39477 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39478
39479 END
39480
39481*$ CREATE PHO_DORGFS.FOR
39482*COPY PHO_DORGFS
39483CDECK ID>, PHO_DORGFS
39484 DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39485 & C,D,E,ES)
39486 IMPLICIT DOUBLE PRECISION (A - Z)
39487 SAVE
39488
39489 IF (S .LE. SF) THEN
39490 PHO_DORGFS = 0.0
39491 ELSE
39492 SX = SQRT (X)
39493 LX = LOG (1./X)
39494 DS = S - SF
39495 PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39496 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39497 END IF
39498
39499 END
39500
39501*$ CREATE PHO_DORGLV.FOR
39502*COPY PHO_DORGLV
39503CDECK ID>, PHO_DORGLV
39504* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39505* *
39506* G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
39507* *
39508* FOR A DETAILED EXPLANATION SEE *
39509* M. GLUECK, E.REYA, M. STRATMANN : *
39510* PHYS. REV. D51 (1995) 3220 *
39511* *
39512* THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
39513* Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
39514* AND (!) Q**2 > 5 P**2 *
39515* P**2 / GEV**2 BETWEEN 0.0 AND 10. *
39516* P**2 = 0 <=> REAL PHOTON *
39517* X BETWEEN 1.E-4 AND 1. *
39518* *
39519* HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
39520* M(C) = 1.5, M(B) = 4.5 *
39521* CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
39522* LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
39523* LAMBDA(5) = 0.153, *
39524* THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
39525* EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
39526* ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
39527* *
39528* PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
39529* Marco.Stratmann@durham.ac.uk *
39530* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39531*
39532*...INPUT PARAMETERS :
39533*
39534* X = MOMENTUM FRACTION
39535* Q2 = SCALE Q**2 IN GEV**2
39536* P2 = VIRTUALITY OF THE PHOTON IN GEV**2
39537*
39538*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39539*
39540********************************************************
39541* subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39542 subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39543 implicit double precision (a-z)
39544 save
39545
39546C input/output channels
39547 INTEGER LI,LO
39548 COMMON /POINOU/ LI,LO
39549
39550 integer check
39551c
39552c check limits :
39553c
39554 check=0
39555 if(x.lt.0.0001d0) check=1
39556 if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
39557 if(q2.lt.5.d0*p2) check=1
39558c
39559c calculate distributions
39560c
39561 if(check.eq.0) then
39562 call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39563 else
39564 WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39565 WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39566 endif
39567
39568 end
39569
39570*$ CREATE PHO_grscalc.FOR
39571*COPY PHO_grscalc
39572CDECK ID>, PHO_grscalc
39573 subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39574 implicit double precision (a-z)
39575 save
39576
39577 dimension u1(40),ds1(40),g1(40)
39578 dimension ud2(20),s2(20),g2(20)
39579 dimension up0(20),dsp0(20),gp0(20)
39580**sr
39581C save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
39582**
39583c
39584 data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39585 & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39586 & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39587 & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39588 & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39589 & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39590 & 0.622d0,0.227d0,-0.184d0/
39591 data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39592 & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39593 & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39594 & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39595 & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39596 & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39597 & 0.245d0,-0.171d0/
39598 data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39599 & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39600 & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39601 & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39602 & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39603 & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39604 data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39605 & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39606 & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39607 & -0.614d0,3.548d0/
39608 data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39609 & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39610 & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39611 & -0.48d0,3.401d0/
39612 data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39613 & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39614 & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39615 & -0.079d0/
39616 data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39617 & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39618 & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39619 & 2.294d0/
39620 data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39621 & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39622 & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39623 & 0.814d0,1.531d0,0.124d0/
39624 data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39625 & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39626 & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39627 & 2.264d0,0.2675d0/
39628c
39629 mu2=0.25d0
39630 lam2=0.232d0*0.232d0
39631c
39632 if(p2.le.0.25d0) then
39633 s=log(log(q2/lam2)/log(mu2/lam2))
39634 lp1=0.d0
39635 lp2=0.d0
39636 else
39637 s=log(log(q2/lam2)/log(p2/lam2))
39638 lp1=log(p2/mu2)*log(p2/mu2)
39639 lp2=log(p2/mu2+log(p2/mu2))
39640 endif
39641c
39642 alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39643 bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39644 a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39645 & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39646 b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39647 & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39648 & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39649 gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39650 & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39651 & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39652 ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39653 & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39654 gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39655 & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39656 gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39657 & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39658 ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39659 & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39660 gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39661 & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39662 upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39663c
39664 alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39665 bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39666 a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39667 & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39668 b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39669 & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39670 & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39671 gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39672 & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39673 & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39674 ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39675 & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39676 gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39677 & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39678 gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39679 & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39680 ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39681 & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39682 gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39683 & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39684 dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39685c
39686 alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39687 bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39688 a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39689 & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39690 b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39691 & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39692 gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39693 & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39694 ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39695 & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39696 & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39697 gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39698 & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39699 gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39700 & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39701 & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39702 ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39703 & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39704 gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39705 & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39706 gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39707c
39708 s=log(log(q2/lam2)/log(mu2/lam2))
39709 suppr=1.d0/(1.d0+p2/0.59d0)**2
39710c
39711 alp=ud2(1)
39712 bet=ud2(2)
39713 a=ud2(3)+ud2(4)*s
39714 ga=ud2(5)+ud2(6)*s**0.5
39715 gc=ud2(7)+ud2(8)*s
39716 b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39717 gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39718 gd=ud2(15)+ud2(16)*s
39719 ge=ud2(17)+ud2(18)*s
39720 gep=ud2(19)+ud2(20)*s
39721 udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39722c
39723 alp=s2(1)
39724 bet=s2(2)
39725 a=s2(3)+s2(4)*s
39726 ga=s2(5)+s2(6)*s**0.5
39727 gc=s2(7)+s2(8)*s
39728 b=s2(9)+s2(10)*s+s2(11)*s**2
39729 gb=s2(12)+s2(13)*s+s2(14)*s**2
39730 gd=s2(15)+s2(16)*s
39731 ge=s2(17)+s2(18)*s
39732 gep=s2(19)+s2(20)*s
39733 spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39734c
39735 alp=g2(1)
39736 bet=g2(2)
39737 a=g2(3)+g2(4)*s**0.5
39738 b=g2(5)+g2(6)*s**2
39739 gb=g2(7)+g2(8)*s
39740 ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39741 gc=g2(12)+g2(13)*s**2
39742 gd=g2(14)+g2(15)*s+g2(16)*s**2
39743 ge=g2(17)+g2(18)*s
39744 gep=g2(19)+g2(20)*s
39745 gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39746c
39747 ugam=upart1+udpart2
39748 dgam=dspart1+udpart2
39749 sgam=dspart1+spart2
39750 ggam=gpart1+gpart2
39751c
39752 end
39753
39754*$ CREATE PHO_grsf1.FOR
39755*COPY PHO_grsf1
39756CDECK ID>, PHO_grsf1
39757 DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39758 & ge,gep)
39759 implicit double precision (a-z)
39760 save
39761
39762 PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39763 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39764 & (1.d0-x)**gd
39765
39766 end
39767
39768*$ CREATE PHO_grsf2.FOR
39769*COPY PHO_grsf2
39770CDECK ID>, PHO_grsf2
39771 DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39772 & ge,gep)
39773 implicit double precision (a-z)
39774 save
39775
39776 PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39777 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39778 & (1.d0-x)**gd
39779
39780 end
39781
39782*$ CREATE PHO_CKMTPA.FOR
39783*COPY PHO_CKMTPA
39784CDECK ID>, PHO_CKMTPA
39785 SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39786C**********************************************************************
39787C
39788C PDF based on Regge theory, evolved with .... by ....
39789C
39790C input: IPAR 2212 proton (not installed)
39791C 990 Pomeron
39792C
39793C output: parameters of parametrization
39794C
39795C**********************************************************************
39796 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39797 SAVE
39798
39799 CHARACTER*8 PDFNA
39800
39801C input/output channels
39802 INTEGER LI,LO
39803 COMMON /POINOU/ LI,LO
39804
39805 REAL PROP(40),POMP(40)
39806 DATA PROP /
39807 & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39808 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39809 & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39810 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39811 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39812 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39813 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39814 & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39815 DATA POMP /
39816 & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39817 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39818 & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
39819 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39820 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39821 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39822 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39823 & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39824
39825 IF(IPA.EQ.2212) THEN
39826 ALA =PROP(1)
39827 Q2MI = PROP(39)
39828 Q2MA = PROP(40)
39829 PDFNA = 'CKMT-PRO'
39830 ELSE IF(IPA.EQ.990) THEN
39831 ALA = POMP(1)
39832 Q2MI = POMP(39)
39833 Q2MA = POMP(40)
39834 PDFNA = 'CKMT-POM'
39835 ELSE
39836 WRITE(LO,'(1X,A,I7)')
39837 & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
39838 STOP
39839 ENDIF
39840 XMI = 1.D-4
39841 XMA = 1.D0
39842 END
39843
39844*$ CREATE PHO_CKMTPD.FOR
39845*COPY PHO_CKMTPD
39846CDECK ID>, PHO_CKMTPD
39847 SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39848C**********************************************************************
39849C
39850C PDF based on Regge theory, evolved with .... by ....
39851C
39852C input: IPAR 2212 proton (not installed)
39853C 990 Pomeron
39854C
39855C output: PD(-6:6) x*f(x) parton distribution functions
39856C (PDFLIB convention: d = PD(1), u = PD(2) )
39857C
39858C**********************************************************************
39859 SAVE
39860
39861C input/output channels
39862 INTEGER LI,LO
39863 COMMON /POINOU/ LI,LO
39864
39865 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
39866 DIMENSION QQ(7)
39867
39868 Q2=SNGL(SCALE2)
39869 Q1S=Q2
39870 XX=SNGL(X)
39871C QCD lambda for evolution
39872 OWLAM = 0.23D0
39873 OWLAM2=OWLAM**2
39874C Q0**2 for evolution
39875 Q02 = 2.D0
39876C
39877C
39878C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39879C q(6)=x*charm, q(7)=x*gluon
39880C
39881 SB=0.
39882 IF(Q2-Q02) 1,1,2
39883 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39884 1 CONTINUE
39885 IF(IPAR.EQ.2212) THEN
39886* CALL PHO_CKMTPR(XX,SB,QQ
39887 WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39888 CALL PHO_ABORT
39889 ELSE
39890 CALL PHO_CKMTPO(XX,SB,QQ)
39891 ENDIF
39892C
39893 PD(-6) = 0.D0
39894 PD(-5) = 0.D0
39895 PD(-4) = DBLE(QQ(6))
39896 PD(-3) = DBLE(QQ(3))
39897 PD(-2) = DBLE(QQ(4))
39898 PD(-1) = DBLE(QQ(5))
39899 PD(0) = DBLE(QQ(7))
39900 PD(1) = DBLE(QQ(2))
39901 PD(2) = DBLE(QQ(1))
39902 PD(3) = DBLE(QQ(3))
39903 PD(4) = DBLE(QQ(6))
39904 PD(5) = 0.D0
39905 PD(6) = 0.D0
39906 IF(IPAR.EQ.990) THEN
39907 CDN = (PD(1)-PD(-1))/2.D0
39908 CUP = (PD(2)-PD(-2))/2.D0
39909 PD(-1) = PD(-1) + CDN
39910 PD(-2) = PD(-2) + CUP
39911 PD(1) = PD(-1)
39912 PD(2) = PD(-2)
39913 ENDIF
39914 END
39915
39916*$ CREATE PHO_CKMTPO.FOR
39917*COPY PHO_CKMTPO
39918CDECK ID>, PHO_CKMTPO
39919 SUBROUTINE PHO_CKMTPO(X,S,QQ)
39920C**********************************************************************
39921C
39922C calculation partons in Pomeron
39923C
39924C**********************************************************************
39925 SAVE
39926
39927 DIMENSION QQ(7)
39928
39929C input/output channels
39930 INTEGER LI,LO
39931 COMMON /POINOU/ LI,LO
39932
39933 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39934 EQUIVALENCE (GF(1,1,1),DL(1))
39935 DATA DELTA/.10/
39936
39937C RNG= -.5
39938C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
39939C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
39940 DATA (DL(K),K= 1, 85) /
39941 & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39942 & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39943 & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39944 & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39945 & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39946 & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39947 & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39948 & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39949 & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39950 & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39951 & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39952 & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39953 & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39954 & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39955 & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39956 & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39957 & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39958 DATA (DL(K),K= 86, 170) /
39959 & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39960 & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39961 & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39962 & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39963 & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39964 & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39965 & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39966 & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39967 & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39968 & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39969 & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39970 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39971 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39972 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39973 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39974 & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39975 & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39976 DATA (DL(K),K= 171, 255) /
39977 & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39978 & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39979 & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39980 & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39981 & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39982 & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39983 & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39984 & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39985 & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39986 & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39987 & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39988 & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39989 & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39990 & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39991 & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39992 & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39993 & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39994 DATA (DL(K),K= 256, 340) /
39995 & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39996 & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39997 & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39998 & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39999 & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
40000 & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
40001 & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
40002 & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
40003 & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40004 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40005 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40006 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40007 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40008 & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
40009 & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
40010 & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
40011 & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
40012 DATA (DL(K),K= 341, 425) /
40013 & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
40014 & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
40015 & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
40016 & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
40017 & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
40018 & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
40019 & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
40020 & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
40021 & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
40022 & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
40023 & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
40024 & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
40025 & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
40026 & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
40027 & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
40028 & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
40029 & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
40030 DATA (DL(K),K= 426, 510) /
40031 & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
40032 & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
40033 & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
40034 & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
40035 & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
40036 & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
40037 & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40038 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40039 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40040 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40041 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40042 & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
40043 & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
40044 & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
40045 & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
40046 & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
40047 & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
40048 DATA (DL(K),K= 511, 595) /
40049 & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
40050 & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
40051 & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
40052 & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
40053 & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
40054 & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
40055 & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
40056 & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
40057 & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
40058 & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
40059 & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
40060 & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
40061 & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
40062 & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
40063 & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
40064 & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
40065 & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
40066 DATA (DL(K),K= 596, 680) /
40067 & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
40068 & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
40069 & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
40070 & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
40071 & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40072 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40073 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40074 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40075 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40076 & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
40077 & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
40078 & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
40079 & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
40080 & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
40081 & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
40082 & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
40083 & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
40084 DATA (DL(K),K= 681, 765) /
40085 & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
40086 & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
40087 & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
40088 & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
40089 & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
40090 & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
40091 & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
40092 & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
40093 & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
40094 & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
40095 & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
40096 & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
40097 & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
40098 & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
40099 & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
40100 & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
40101 & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
40102 DATA (DL(K),K= 766, 850) /
40103 & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
40104 & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
40105 & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40106 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40107 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40108 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40109 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40110 & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
40111 & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
40112 & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
40113 & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
40114 & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
40115 & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
40116 & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
40117 & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
40118 & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
40119 & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
40120 DATA (DL(K),K= 851, 935) /
40121 & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
40122 & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
40123 & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
40124 & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
40125 & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
40126 & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
40127 & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
40128 & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
40129 & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
40130 & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
40131 & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
40132 & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
40133 & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
40134 & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
40135 & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
40136 & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
40137 & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
40138 DATA (DL(K),K= 936, 1020) /
40139 & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40140 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40141 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40142 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40143 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40144 & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
40145 & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
40146 & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
40147 & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
40148 & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
40149 & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
40150 & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
40151 & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
40152 & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
40153 & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
40154 & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
40155 & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
40156 DATA (DL(K),K= 1021, 1105) /
40157 & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
40158 & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
40159 & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
40160 & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
40161 & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
40162 & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
40163 & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
40164 & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
40165 & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
40166 & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
40167 & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
40168 & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
40169 & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
40170 & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
40171 & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
40172 & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40173 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40174 DATA (DL(K),K= 1106, 1190) /
40175 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40176 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40177 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40178 & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
40179 & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
40180 & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
40181 & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
40182 & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
40183 & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
40184 & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
40185 & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
40186 & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
40187 & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
40188 & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
40189 & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
40190 & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
40191 & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
40192 DATA (DL(K),K= 1191, 1275) /
40193 & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
40194 & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
40195 & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
40196 & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
40197 & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
40198 & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
40199 & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
40200 & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
40201 & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
40202 & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
40203 & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
40204 & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
40205 & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
40206 & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40207 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40208 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40209 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40210 DATA (DL(K),K= 1276, 1360) /
40211 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40212 & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
40213 & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
40214 & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
40215 & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
40216 & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
40217 & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
40218 & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
40219 & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
40220 & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
40221 & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
40222 & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
40223 & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
40224 & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
40225 & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
40226 & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
40227 & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
40228 DATA (DL(K),K= 1361, 1445) /
40229 & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
40230 & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
40231 & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
40232 & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
40233 & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
40234 & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
40235 & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
40236 & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
40237 & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
40238 & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
40239 & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
40240 & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40241 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40242 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40243 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40244 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40245 & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
40246 DATA (DL(K),K= 1446, 1530) /
40247 & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
40248 & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
40249 & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
40250 & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
40251 & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
40252 & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
40253 & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
40254 & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
40255 & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
40256 & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
40257 & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
40258 & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
40259 & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
40260 & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
40261 & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
40262 & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
40263 & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
40264 DATA (DL(K),K= 1531, 1615) /
40265 & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
40266 & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
40267 & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
40268 & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
40269 & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
40270 & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
40271 & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
40272 & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
40273 & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
40274 & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40275 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40276 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40277 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40278 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40279 & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
40280 & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
40281 & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
40282 DATA (DL(K),K= 1616, 1700) /
40283 & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
40284 & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
40285 & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
40286 & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
40287 & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
40288 & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
40289 & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
40290 & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
40291 & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
40292 & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
40293 & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
40294 & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
40295 & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
40296 & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
40297 & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
40298 & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
40299 & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
40300 DATA (DL(K),K= 1701, 1785) /
40301 & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
40302 & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
40303 & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
40304 & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
40305 & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
40306 & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
40307 & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
40308 & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40309 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40310 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40311 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40312 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40313 & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
40314 & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
40315 & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
40316 & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
40317 & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
40318 DATA (DL(K),K= 1786, 1870) /
40319 & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
40320 & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
40321 & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
40322 & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
40323 & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
40324 & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
40325 & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
40326 & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
40327 & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
40328 & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
40329 & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
40330 & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
40331 & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
40332 & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
40333 & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
40334 & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
40335 & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
40336 DATA (DL(K),K= 1871, 1955) /
40337 & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
40338 & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
40339 & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
40340 & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
40341 & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
40342 & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40343 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40344 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40345 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40346 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40347 & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
40348 & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
40349 & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
40350 & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
40351 & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
40352 & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
40353 & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
40354 DATA (DL(K),K= 1956, 2040) /
40355 & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
40356 & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
40357 & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
40358 & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
40359 & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
40360 & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
40361 & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
40362 & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
40363 & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
40364 & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
40365 & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
40366 & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
40367 & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
40368 & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
40369 & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
40370 & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
40371 & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
40372 DATA (DL(K),K= 2041, 2125) /
40373 & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
40374 & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
40375 & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
40376 & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40377 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40378 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40379 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40380 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40381 & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
40382 & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
40383 & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
40384 & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
40385 & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
40386 & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
40387 & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
40388 & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
40389 & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
40390 DATA (DL(K),K= 2126, 2210) /
40391 & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
40392 & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
40393 & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
40394 & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
40395 & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
40396 & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
40397 & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
40398 & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
40399 & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
40400 & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
40401 & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
40402 & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
40403 & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
40404 & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
40405 & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
40406 & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
40407 & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
40408 DATA (DL(K),K= 2211, 2295) /
40409 & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
40410 & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40411 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40412 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40413 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40414 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40415 & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
40416 & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
40417 & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
40418 & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
40419 & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
40420 & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
40421 & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
40422 & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
40423 & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
40424 & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
40425 & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
40426 DATA (DL(K),K= 2296, 2380) /
40427 & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
40428 & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
40429 & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
40430 & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
40431 & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
40432 & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
40433 & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
40434 & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
40435 & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
40436 & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
40437 & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
40438 & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
40439 & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
40440 & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
40441 & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
40442 & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
40443 & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40444 DATA (DL(K),K= 2381, 2465) /
40445 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40446 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40447 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40448 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40449 & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40450 & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40451 & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40452 & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40453 & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40454 & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40455 & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40456 & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40457 & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40458 & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40459 & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40460 & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40461 & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40462 DATA (DL(K),K= 2466, 2550) /
40463 & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40464 & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40465 & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40466 & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40467 & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40468 & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40469 & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40470 & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40471 & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40472 & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40473 & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40474 & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40475 & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40476 & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40477 & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40478 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40479 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40480 DATA (DL(K),K= 2551, 2635) /
40481 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40482 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40483 & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40484 & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40485 & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40486 & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40487 & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40488 & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40489 & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40490 & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40491 & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40492 & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40493 & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40494 & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40495 & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40496 & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40497 & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40498 DATA (DL(K),K= 2636, 2720) /
40499 & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40500 & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40501 & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40502 & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40503 & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40504 & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40505 & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40506 & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40507 & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40508 & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40509 & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40510 & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40511 & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40512 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40513 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40514 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40515 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40516 DATA (DL(K),K= 2721, 2805) /
40517 & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40518 & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40519 & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40520 & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40521 & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40522 & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40523 & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40524 & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40525 & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40526 & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40527 & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40528 & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40529 & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40530 & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40531 & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40532 & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40533 & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40534 DATA (DL(K),K= 2806, 2890) /
40535 & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40536 & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40537 & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40538 & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40539 & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40540 & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40541 & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40542 & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40543 & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40544 & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40545 & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40546 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40547 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40548 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40549 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40550 & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40551 & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40552 DATA (DL(K),K= 2891, 2975) /
40553 & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40554 & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40555 & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40556 & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40557 & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40558 & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40559 & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40560 & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40561 & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40562 & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40563 & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40564 & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40565 & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40566 & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40567 & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40568 & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40569 & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40570 DATA (DL(K),K= 2976, 3060) /
40571 & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40572 & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40573 & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40574 & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40575 & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40576 & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40577 & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40578 & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40579 & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40580 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40581 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40582 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40583 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40584 & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40585 & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40586 & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40587 & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40588 DATA (DL(K),K= 3061, 3145) /
40589 & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40590 & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40591 & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40592 & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40593 & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40594 & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40595 & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40596 & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40597 & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40598 & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40599 & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40600 & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40601 & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40602 & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40603 & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40604 & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40605 & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40606 DATA (DL(K),K= 3146, 3230) /
40607 & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40608 & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40609 & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40610 & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40611 & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40612 & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40613 & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40614 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40615 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40616 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40617 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40618 & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40619 & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40620 & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40621 & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40622 & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40623 & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40624 DATA (DL(K),K= 3231, 3315) /
40625 & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40626 & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40627 & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40628 & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40629 & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40630 & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40631 & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40632 & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40633 & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40634 & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40635 & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40636 & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40637 & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40638 & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40639 & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40640 & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40641 & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40642 DATA (DL(K),K= 3316, 3400) /
40643 & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40644 & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40645 & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40646 & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40647 & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40648 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40649 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40650 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40651 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40652 & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40653 & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40654 & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40655 & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40656 & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40657 & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40658 & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40659 & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40660 DATA (DL(K),K= 3401, 3485) /
40661 & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40662 & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40663 & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40664 & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40665 & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40666 & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40667 & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40668 & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40669 & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40670 & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40671 & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40672 & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40673 & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40674 & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40675 & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40676 & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40677 & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40678 DATA (DL(K),K= 3486, 3570) /
40679 & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40680 & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40681 & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40682 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40683 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40684 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40685 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40686 & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40687 & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40688 & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40689 & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40690 & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40691 & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40692 & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40693 & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40694 & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40695 & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40696 DATA (DL(K),K= 3571, 3655) /
40697 & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40698 & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40699 & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40700 & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40701 & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40702 & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40703 & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40704 & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40705 & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40706 & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40707 & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40708 & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40709 & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40710 & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40711 & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40712 & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40713 & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40714 DATA (DL(K),K= 3656, 3740) /
40715 & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40716 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40717 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40718 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40719 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40720 & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40721 & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40722 & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40723 & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40724 & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40725 & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40726 & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40727 & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40728 & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40729 & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40730 & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40731 & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40732 DATA (DL(K),K= 3741, 3825) /
40733 & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40734 & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40735 & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40736 & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40737 & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40738 & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40739 & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40740 & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40741 & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40742 & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40743 & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40744 & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40745 & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40746 & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40747 & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40748 & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40749 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40750 DATA (DL(K),K= 3826, 3910) /
40751 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40752 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40753 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40754 & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40755 & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40756 & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40757 & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40758 & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40759 & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40760 & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40761 & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40762 & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40763 & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40764 & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40765 & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40766 & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40767 & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40768 DATA (DL(K),K= 3911, 3995) /
40769 & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40770 & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40771 & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40772 & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40773 & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40774 & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40775 & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40776 & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40777 & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40778 & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40779 & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40780 & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40781 & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40782 & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40783 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40784 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40785 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40786 DATA (DL(K),K= 3996, 4000) /
40787 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40788
40789 DO 10 I=1,7
40790 QQ(I) = 0.
40791 10 CONTINUE
40792 IF(X.GT.0.9985) RETURN
40793
40794 IS = S/DELTA+1
40795 IS = MIN(IS,19)
40796 IS1 = IS+1
40797 DO 20 I=1,7
40798 IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40799 IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40800 DO 30 L=1,25
40801 F1(L)=GF(I,IS,L)
40802 F2(L)=GF(I,IS1,L)
40803 30 CONTINUE
40804 S1=(IS-1)*DELTA
40805 S2=S1+DELTA
40806 A1 = PHO_CKMTFV(X,F1)
40807 A2 = PHO_CKMTFV(X,F2)
40808 QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40809 19 CONTINUE
40810 20 CONTINUE
40811
40812 END
40813
40814*$ CREATE PHO_CKMTFV.FOR
40815*COPY PHO_CKMTFV
40816CDECK ID>, PHO_CKMTFV
40817 REAL FUNCTION PHO_CKMTFV(X,FVL)
40818C**********************************************************************
40819C
40820C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40821C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40822C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40823C IN MAIN ROUTINE.
40824C
40825C**********************************************************************
40826 SAVE
40827
40828 DIMENSION FVL(25),XGRID(25)
40829
40830C input/output channels
40831 INTEGER LI,LO
40832 COMMON /POINOU/ LI,LO
40833
40834 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40835 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40836
40837 PHO_CKMTFV=0.
40838 DO 1 I=1,NX
40839 IF(X.LT.XGRID(I)) GO TO 2
40840 1 CONTINUE
40841 2 I=I-1
40842 IF(I.EQ.0) THEN
40843 I=I+1
40844 ELSE IF(I.GT.23) THEN
40845 I=23
40846 ENDIF
40847 J=I+1
40848 K=J+1
40849 AXI=LOG(XGRID(I))
40850 BXI=LOG(1.-XGRID(I))
40851 AXJ=LOG(XGRID(J))
40852 BXJ=LOG(1.-XGRID(J))
40853 AXK=LOG(XGRID(K))
40854 BXK=LOG(1.-XGRID(K))
40855 FI=LOG(ABS(FVL(I)) +1.E-15)
40856 FJ=LOG(ABS(FVL(J)) +1.E-16)
40857 FK=LOG(ABS(FVL(K)) +1.E-17)
40858 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40859 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40860 $ BXI))/DET
40861 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40862 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40863 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40864 1RETURN
40865C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40866C WRITE(LO,2001) X,FVL
40867C 2001 FORMAT(8E12.4)
40868C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40869C ENDIF
40870 PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40871
40872 END
40873
40874*$ CREATE PHO_SASGAM.FOR
40875*COPY PHO_SASGAM
40876CDECK ID>, PHO_SASGAM
40877C***********************************************************************
40878C...SaSgam version 2 - parton distributions of the photon
40879C...by Gerhard A. Schuler and Torbjorn Sjostrand
40880C...For further information see Z. Phys. C68 (1995) 607
40881C...and Phys. Lett. B376 (1996) 193.
40882
40883C...18 January 1996: original code.
40884C...22 July 1996: calculation of BETA moved in SASBEH.
40885
40886C!!!Note that one further call parameter - IP2 - has been added
40887C!!!to the SASGAM argument list compared with version 1.
40888
40889C...The user should only need to call the SASGAM routine,
40890C...which in turn calls the auxiliary routines SASVMD, SASANO,
40891C...SASBEH and SASDIR. The package is self-contained.
40892
40893C...One particular aspect of these parametrizations is that F2 for
40894C...the photon is not obtained just as the charge-squared-weighted
40895C...sum of quark distributions, but differ in the treatment of
40896C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40897C...the kinematics range of heavy-flavour production, but the same
40898C...kinematics is not relevant e.g. for jet production) and, for the
40899C...'MSbar' fits, in the addition of a Cgamma term related to the
40900C...separation of direct processes. Schematically:
40901C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40902C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
40903C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40904C...The J/psi and Upsilon states have not been included in the VMD sum,
40905C...but low c and b masses in the other components should compensate
40906C...for this in a duality sense.
40907
40908C...The calling sequence is the following:
40909C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40910C...with the following declaration statement:
40911C DIMENSION XPDFGM(-6:6)
40912C...and, optionally, further information in:
40913C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40914C &XPDIR(-6:6)
40915C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40916C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
40917C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40918C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
40919C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
40920C X : x value.
40921C Q2 : Q2 value.
40922C P2 : P2 value; should be = 0. for an on-shell photon.
40923C IP2 : scheme used to evaluate off-shell anomalous component.
40924C = 0 : recommended default, see = 7.
40925C = 1 : dipole dampening by integration; very time-consuming.
40926C = 2 : P_0^2 = max( Q_0^2, P^2 )
40927C = 3 : P_0^2 = Q_0^2 + P^2.
40928C = 4 : P_{eff} that preserves momentum sum.
40929C = 5 : P_{int} that preserves momentum and average
40930C evolution range.
40931C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40932C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40933C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40934C XPFDGM : x times parton distribution functions of the photon,
40935C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40936C 6 = t (always empty!), - for antiquarks (result is same).
40937C...The breakdown by component is stored in the commonblock SASCOM,
40938C with elements as above.
40939C XPVMD : rho, omega, phi VMD part only of output.
40940C XPANL : d, u, s anomalous part only of output.
40941C XPANH : c, b anomalous part only of output.
40942C XPBEH : c, b Bethe-Heitler part only of output.
40943C XPDIR : Cgamma (direct contribution) part only of output.
40944C...The above arrays do not distinguish valence and sea contributions,
40945C...although this information is available internally. The additional
40946C...commonblock SASVAL provides the valence part only of the above
40947C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40948C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40949C...and therefore not given doubly. VXPDGM gives the sum of valence
40950C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40951C...and so on, gives the sea part only.
40952C***********************************************************************
40953
40954 SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40955C...Purpose: to construct the F2 and parton distributions of the photon
40956C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40957C...For F2, c and b are included by the Bethe-Heitler formula;
40958C...in the 'MSbar' scheme additionally a Cgamma term is added.
40959 SAVE
40960 DIMENSION XPDFGM(-6:6)
40961
40962C input/output channels
40963 INTEGER LI,LO
40964 COMMON /POINOU/ LI,LO
40965
40966 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40967 &XPDIR(-6:6)
40968 COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40969**sr
40970C SAVE /SASCOM/,/SASVAL/
40971**
40972
40973C...Temporary array.
40974 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40975C...Charm and bottom masses (low to compensate for J/psi etc.).
40976 DATA PMC/1.3/, PMB/4.6/
40977C...alpha_em and alpha_em/(2*pi).
40978 DATA AEM/0.007297/, AEM2PI/0.0011614/
40979C...Lambda value for 4 flavours.
40980 DATA ALAM/0.20/
40981C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40982 DATA FRACU/0.8/
40983C...VMD couplings f_V**2/(4*pi).
40984 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40985C...Masses for rho (=omega) and phi.
40986 DATA PMRHO/0.770/, PMPHI/1.020/
40987C...Number of points in integration for IP2=1.
40988 DATA NSTEP/100/
40989
40990C...Reset output.
40991 F2GM=0.
40992 DO 100 KFL=-6,6
40993 XPDFGM(KFL)=0.
40994 XPVMD(KFL)=0.
40995 XPANL(KFL)=0.
40996 XPANH(KFL)=0.
40997 XPBEH(KFL)=0.
40998 XPDIR(KFL)=0.
40999 VXPVMD(KFL)=0.
41000 VXPANL(KFL)=0.
41001 VXPANH(KFL)=0.
41002 VXPDGM(KFL)=0.
41003 100 CONTINUE
41004
41005C...Check that input sensible.
41006 IF(ISET.LE.0.OR.ISET.GE.5) THEN
41007 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
41008 WRITE(LO,*) ' ISET = ',ISET
41009 STOP
41010 ENDIF
41011 IF(X.LE.0..OR.X.GT.1.) THEN
41012 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
41013 WRITE(LO,*) ' X = ',X
41014 STOP
41015 ENDIF
41016
41017C...Set Q0 cut-off parameter as function of set used.
41018 IF(ISET.LE.2) THEN
41019 Q0=0.6
41020 ELSE
41021 Q0=2.
41022 ENDIF
41023 Q02=Q0**2
41024
41025C...Scale choice for off-shell photon; common factors.
41026 Q2A=Q2
41027 FACNOR=1.
41028 IF(IP2.EQ.1) THEN
41029 P2MX=P2+Q02
41030 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
41031 FACNOR=LOG(Q2/Q02)/NSTEP
41032 ELSEIF(IP2.EQ.2) THEN
41033 P2MX=MAX(P2,Q02)
41034 ELSEIF(IP2.EQ.3) THEN
41035 P2MX=P2+Q02
41036 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
41037 ELSEIF(IP2.EQ.4) THEN
41038 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41039 & ((Q2+P2)*(Q02+P2)))
41040 ELSEIF(IP2.EQ.5) THEN
41041 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41042 & ((Q2+P2)*(Q02+P2)))
41043 P2MX=Q0*SQRT(P2MXA)
41044 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
41045 ELSEIF(IP2.EQ.6) THEN
41046 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41047 & ((Q2+P2)*(Q02+P2)))
41048 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
41049 ELSE
41050 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41051 & ((Q2+P2)*(Q02+P2)))
41052 P2MX=Q0*SQRT(P2MXA)
41053 P2MXB=P2MX
41054 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
41055 P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
41056 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
41057 ENDIF
41058
41059C...Call VMD parametrization for d quark and use to give rho, omega,
41060C...phi. Note dipole dampening for off-shell photon.
41061 CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41062 XFVAL=VXPGA(1)
41063 XPGA(1)=XPGA(2)
41064 XPGA(-1)=XPGA(-2)
41065 FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
41066 FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
41067 DO 110 KFL=-5,5
41068 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
41069 110 CONTINUE
41070 XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
41071 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
41072 XPVMD(3)=XPVMD(3)+FACS*XFVAL
41073 XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
41074 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
41075 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
41076 VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
41077 VXPVMD(2)=FRACU*FACUD*XFVAL
41078 VXPVMD(3)=FACS*XFVAL
41079 VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
41080 VXPVMD(-2)=FRACU*FACUD*XFVAL
41081 VXPVMD(-3)=FACS*XFVAL
41082
41083 IF(IP2.NE.1) THEN
41084C...Anomalous parametrizations for different strategies
41085C...for off-shell photons; except full integration.
41086
41087C...Call anomalous parametrization for d + u + s.
41088 CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41089 DO 120 KFL=-5,5
41090 XPANL(KFL)=FACNOR*XPGA(KFL)
41091 VXPANL(KFL)=FACNOR*VXPGA(KFL)
41092 120 CONTINUE
41093
41094C...Call anomalous parametrization for c and b.
41095 CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41096 DO 130 KFL=-5,5
41097 XPANH(KFL)=FACNOR*XPGA(KFL)
41098 VXPANH(KFL)=FACNOR*VXPGA(KFL)
41099 130 CONTINUE
41100 CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41101 DO 140 KFL=-5,5
41102 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
41103 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
41104 140 CONTINUE
41105
41106 ELSE
41107C...Special option: loop over flavours and integrate over k2.
41108 DO 170 KF=1,5
41109 DO 160 ISTEP=1,NSTEP
41110 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
41111 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
41112 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
41113 CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
41114 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
41115 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
41116 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
41117 DO 150 KFL=-5,5
41118 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
41119 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
41120 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
41121 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
41122 150 CONTINUE
41123 160 CONTINUE
41124 170 CONTINUE
41125 ENDIF
41126
41127C...Call Bethe-Heitler term expression for charm and bottom.
41128 CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
41129 XPBEH(4)=XPBH
41130 XPBEH(-4)=XPBH
41131 CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
41132 XPBEH(5)=XPBH
41133 XPBEH(-5)=XPBH
41134
41135C...For MSbar subtraction call C^gamma term expression for d, u, s.
41136 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
41137 CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41138 DO 180 KFL=-5,5
41139 XPDIR(KFL)=XPGA(KFL)
41140 180 CONTINUE
41141 ENDIF
41142
41143C...Store result in output array.
41144 DO 190 KFL=-5,5
41145 CHSQ=1./9.
41146 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
41147 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
41148 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
41149 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
41150 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
41151 190 CONTINUE
41152
41153 RETURN
41154 END
41155
41156C*********************************************************************
41157
41158*$ CREATE PHO_SASVMD.FOR
41159*COPY PHO_SASVMD
41160CDECK ID>, PHO_SASVMD
41161 SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
41162C...Purpose: to evaluate the VMD parton distributions of a photon,
41163C...evolved homogeneously from an initial scale P2 to Q2.
41164C...Does not include dipole suppression factor.
41165C...ISET is parton distribution set, see above;
41166C...additionally ISET=0 is used for the evolution of an anomalous photon
41167C...which branched at a scale P2 and then evolved homogeneously to Q2.
41168C...ALAM is the 4-flavour Lambda, which is automatically converted
41169C...to 3- and 5-flavour equivalents as needed.
41170 SAVE
41171 DIMENSION XPGA(-6:6), VXPGA(-6:6)
41172
41173C input/output channels
41174 INTEGER LI,LO
41175 COMMON /POINOU/ LI,LO
41176
41177 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
41178
41179C...Reset output.
41180 DO 100 KFL=-6,6
41181 XPGA(KFL)=0.
41182 VXPGA(KFL)=0.
41183 100 CONTINUE
41184 KFA=IABS(KF)
41185
41186C...Calculate Lambda; protect against unphysical Q2 and P2 input.
41187 ALAM3=ALAM*(PMC/ALAM)**(2./27.)
41188 ALAM5=ALAM*(ALAM/PMB)**(2./23.)
41189 P2EFF=MAX(P2,1.2*ALAM3**2)
41190 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
41191 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
41192 Q2EFF=MAX(Q2,P2EFF)
41193
41194C...Find number of flavours at lower and upper scale.
41195 NFP=4
41196 IF(P2EFF.LT.PMC**2) NFP=3
41197 IF(P2EFF.GT.PMB**2) NFP=5
41198 NFQ=4
41199 IF(Q2EFF.LT.PMC**2) NFQ=3
41200 IF(Q2EFF.GT.PMB**2) NFQ=5
41201
41202C...Find s as sum of 3-, 4- and 5-flavour parts.
41203 S=0.
41204 IF(NFP.EQ.3) THEN
41205 Q2DIV=PMC**2
41206 IF(NFQ.EQ.3) Q2DIV=Q2EFF
41207 S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
41208 ENDIF
41209 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
41210 P2DIV=P2EFF
41211 IF(NFP.EQ.3) P2DIV=PMC**2
41212 Q2DIV=Q2EFF
41213 IF(NFQ.EQ.5) Q2DIV=PMB**2
41214 S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
41215 ENDIF
41216 IF(NFQ.EQ.5) THEN
41217 P2DIV=PMB**2
41218 IF(NFP.EQ.5) P2DIV=P2EFF
41219 S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
41220 ENDIF
41221
41222C...Calculate frequent combinations of x and s.
41223 X1=1.-X
41224 XL=-LOG(X)
41225 S2=S**2
41226 S3=S**3
41227 S4=S**4
41228
41229C...Evaluate homogeneous anomalous parton distributions below or
41230C...above threshold.
41231 IF(ISET.EQ.0) THEN
41232 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41233 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41234 XVAL = X * 1.5 * (X**2+X1**2)
41235 XGLU = 0.
41236 XSEA = 0.
41237 ELSE
41238 XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
41239 & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
41240 & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
41241 XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
41242 & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
41243 & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
41244 XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
41245 & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
41246 & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
41247 & (2.*X-1.)*X*XL**2)
41248 ENDIF
41249
41250C...Evaluate set 1D parton distributions below or above threshold.
41251 ELSEIF(ISET.EQ.1) THEN
41252 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41253 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41254 XVAL = 1.294 * X**0.80 * X1**0.76
41255 XGLU = 1.273 * X**0.40 * X1**1.76
41256 XSEA = 0.100 * X1**3.76
41257 ELSE
41258 XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
41259 & X1**(0.76+0.667*S) * XL**(2.*S)
41260 XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
41261 & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
41262 & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
41263 XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
41264 & X**(-7.32*S2/(1.+10.3*S2)) *
41265 & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
41266 XSEA0 = 0.100 * X1**3.76
41267 ENDIF
41268
41269C...Evaluate set 1M parton distributions below or above threshold.
41270 ELSEIF(ISET.EQ.2) THEN
41271 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41272 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41273 XVAL = 0.8477 * X**0.51 * X1**1.37
41274 XGLU = 3.42 * X**0.255 * X1**2.37
41275 XSEA = 0.
41276 ELSE
41277 XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
41278 & * X1**1.37 * XL**(2.667*S)
41279 XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
41280 & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
41281 & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
41282 & X1**(2.37+3.*S)
41283 XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
41284 & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
41285 & XL**(2.8*S)
41286 XSEA0 = 0.
41287 ENDIF
41288
41289C...Evaluate set 2D parton distributions below or above threshold.
41290 ELSEIF(ISET.EQ.3) THEN
41291 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41292 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41293 XVAL = X**0.46 * X1**0.64 + 0.76 * X
41294 XGLU = 1.925 * X1**2
41295 XSEA = 0.242 * X1**4
41296 ELSE
41297 XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
41298 & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
41299 & (0.76+0.4*S) * X * X1**(2.667*S)
41300 XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
41301 & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
41302 & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
41303 XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
41304 & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
41305 XSEA0 = 0.242 * X1**4
41306 ENDIF
41307
41308C...Evaluate set 2M parton distributions below or above threshold.
41309 ELSEIF(ISET.EQ.4) THEN
41310 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41311 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41312 XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
41313 XGLU = 1.808 * X1**2
41314 XSEA = 0.209 * X1**4
41315 ELSE
41316 XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
41317 & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
41318 & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
41319 & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
41320 XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
41321 & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
41322 & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
41323 & XL**(10.9*S/(1.+2.5*S))
41324 XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
41325 & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
41326 & X1**(4.+S) * XL**(0.45*S)
41327 XSEA0 = 0.209 * X1**4
41328 ENDIF
41329 ENDIF
41330
41331C...Threshold factors for c and b sea.
41332 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41333 XCHM=0.
41334 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41335 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41336 IF(ISET.EQ.0) THEN
41337 XCHM=XSEA*(1.-(SCH/SLL)**2)
41338 ELSE
41339 XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
41340 ENDIF
41341 ENDIF
41342 XBOT=0.
41343 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41344 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41345 IF(ISET.EQ.0) THEN
41346 XBOT=XSEA*(1.-(SBT/SLL)**2)
41347 ELSE
41348 XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
41349 ENDIF
41350 ENDIF
41351
41352C...Fill parton distributions.
41353 XPGA(0)=XGLU
41354 XPGA(1)=XSEA
41355 XPGA(2)=XSEA
41356 XPGA(3)=XSEA
41357 XPGA(4)=XCHM
41358 XPGA(5)=XBOT
41359 XPGA(KFA)=XPGA(KFA)+XVAL
41360 DO 110 KFL=1,5
41361 XPGA(-KFL)=XPGA(KFL)
41362 110 CONTINUE
41363 VXPGA(KFA)=XVAL
41364 VXPGA(-KFA)=XVAL
41365
41366 RETURN
41367 END
41368
41369C*********************************************************************
41370
41371*$ CREATE PHO_SASANO.FOR
41372*COPY PHO_SASANO
41373CDECK ID>, PHO_SASANO
41374 SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
41375C...Purpose: to evaluate the parton distributions of the anomalous
41376C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
41377C...to Q2.
41378C...KF=0 gives the sum over (up to) 5 flavours,
41379C...KF<0 limits to flavours up to abs(KF),
41380C...KF>0 is for flavour KF only.
41381C...ALAM is the 4-flavour Lambda, which is automatically converted
41382C...to 3- and 5-flavour equivalents as needed.
41383 SAVE
41384
41385C input/output channels
41386 INTEGER LI,LO
41387 COMMON /POINOU/ LI,LO
41388
41389 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
41390 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
41391
41392C...Reset output.
41393 DO 100 KFL=-6,6
41394 XPGA(KFL)=0.
41395 VXPGA(KFL)=0.
41396 100 CONTINUE
41397 IF(Q2.LE.P2) RETURN
41398 KFA=IABS(KF)
41399
41400C...Calculate Lambda; protect against unphysical Q2 and P2 input.
41401 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
41402 ALAMSQ(4)=ALAM**2
41403 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
41404 P2EFF=MAX(P2,1.2*ALAMSQ(3))
41405 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
41406 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
41407 Q2EFF=MAX(Q2,P2EFF)
41408 XL=-LOG(X)
41409
41410C...Find number of flavours at lower and upper scale.
41411 NFP=4
41412 IF(P2EFF.LT.PMC**2) NFP=3
41413 IF(P2EFF.GT.PMB**2) NFP=5
41414 NFQ=4
41415 IF(Q2EFF.LT.PMC**2) NFQ=3
41416 IF(Q2EFF.GT.PMB**2) NFQ=5
41417
41418C...Define range of flavour loop.
41419 IF(KF.EQ.0) THEN
41420 KFLMN=1
41421 KFLMX=5
41422 ELSEIF(KF.LT.0) THEN
41423 KFLMN=1
41424 KFLMX=KFA
41425 ELSE
41426 KFLMN=KFA
41427 KFLMX=KFA
41428 ENDIF
41429
41430C...Loop over flavours the photon can branch into.
41431 DO 110 KFL=KFLMN,KFLMX
41432
41433C...Light flavours: calculate t range and (approximate) s range.
41434 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
41435 TDIFF=LOG(Q2EFF/P2EFF)
41436 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41437 & LOG(P2EFF/ALAMSQ(NFQ)))
41438 IF(NFQ.GT.NFP) THEN
41439 Q2DIV=PMB**2
41440 IF(NFQ.EQ.4) Q2DIV=PMC**2
41441 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41442 & LOG(P2EFF/ALAMSQ(NFQ)))
41443 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41444 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41445 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41446 ENDIF
41447 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41448 Q2DIV=PMC**2
41449 SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41450 & LOG(P2EFF/ALAMSQ(4)))
41451 SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41452 & LOG(P2EFF/ALAMSQ(3)))
41453 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41454 ENDIF
41455
41456C...u and s quark do not need a separate treatment when d has been done.
41457 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41458
41459C...Charm: as above, but only include range above c threshold.
41460 ELSEIF(KFL.EQ.4) THEN
41461 IF(Q2.LE.PMC**2) GOTO 110
41462 P2EFF=MAX(P2EFF,PMC**2)
41463 Q2EFF=MAX(Q2EFF,P2EFF)
41464 TDIFF=LOG(Q2EFF/P2EFF)
41465 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41466 & LOG(P2EFF/ALAMSQ(NFQ)))
41467 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41468 Q2DIV=PMB**2
41469 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41470 & LOG(P2EFF/ALAMSQ(NFQ)))
41471 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41472 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41473 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41474 ENDIF
41475
41476C...Bottom: as above, but only include range above b threshold.
41477 ELSEIF(KFL.EQ.5) THEN
41478 IF(Q2.LE.PMB**2) GOTO 110
41479 P2EFF=MAX(P2EFF,PMB**2)
41480 Q2EFF=MAX(Q2,P2EFF)
41481 TDIFF=LOG(Q2EFF/P2EFF)
41482 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41483 & LOG(P2EFF/ALAMSQ(NFQ)))
41484 ENDIF
41485
41486C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41487 CHSQ=1./9.
41488 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41489 FAC=AEM2PI*2.*CHSQ*TDIFF
41490
41491C...Evaluate parton distributions (normalized to unit momentum sum).
41492 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41493 XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41494 & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41495 & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41496 & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41497 XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41498 & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41499 & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41500 XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41501 & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41502 & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41503 & (2.*X-1.)*X*XL**2)
41504
41505C...Threshold factors for c and b sea.
41506 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41507 XCHM=0.
41508 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41509 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41510 XCHM=XSEA*(1.-(SCH/SLL)**3)
41511 ENDIF
41512 XBOT=0.
41513 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41514 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41515 XBOT=XSEA*(1.-(SBT/SLL)**3)
41516 ENDIF
41517 ENDIF
41518
41519C...Add contribution of each valence flavour.
41520 XPGA(0)=XPGA(0)+FAC*XGLU
41521 XPGA(1)=XPGA(1)+FAC*XSEA
41522 XPGA(2)=XPGA(2)+FAC*XSEA
41523 XPGA(3)=XPGA(3)+FAC*XSEA
41524 XPGA(4)=XPGA(4)+FAC*XCHM
41525 XPGA(5)=XPGA(5)+FAC*XBOT
41526 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41527 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41528 110 CONTINUE
41529 DO 120 KFL=1,5
41530 XPGA(-KFL)=XPGA(KFL)
41531 VXPGA(-KFL)=VXPGA(KFL)
41532 120 CONTINUE
41533
41534 END
41535
41536C*********************************************************************
41537
41538*$ CREATE PHO_SASBEH.FOR
41539*COPY PHO_SASBEH
41540CDECK ID>, PHO_SASBEH
41541 SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41542C...Purpose: to evaluate the Bethe-Heitler cross section for
41543C...heavy flavour production.
41544 SAVE
41545 DATA AEM2PI/0.0011614/
41546
41547C...Reset output.
41548 XPBH=0.
41549 SIGBH=0.
41550
41551C...Check kinematics limits.
41552 IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41553 W2=Q2*(1.-X)/X-P2
41554 BETA2=1.-4.*PM2/W2
41555 IF(BETA2.LT.1E-10) RETURN
41556 BETA=SQRT(BETA2)
41557 RMQ=4.*PM2/Q2
41558
41559C...Simple case: P2 = 0.
41560 IF(P2.LT.1E-4) THEN
41561 IF(BETA.LT.0.99) THEN
41562 XBL=LOG((1.+BETA)/(1.-BETA))
41563 ELSE
41564 XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41565 ENDIF
41566 SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41567 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41568
41569C...Complicated case: P2 > 0, based on approximation of
41570C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41571 ELSE
41572 RPQ=1.-4.*X**2*P2/Q2
41573 IF(RPQ.GT.1E-10) THEN
41574 RPBE=SQRT(RPQ*BETA2)
41575 IF(RPBE.LT.0.99) THEN
41576 XBL=LOG((1.+RPBE)/(1.-RPBE))
41577 XBI=2.*RPBE/(1.-RPBE**2)
41578 ELSE
41579 RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41580 XBL=LOG((1.+RPBE)**2/RPBESN)
41581 XBI=2.*RPBE/RPBESN
41582 ENDIF
41583 SIGBH=BETA*(6.*X*(1.-X)-1.)+
41584 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41585 & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41586 ENDIF
41587 ENDIF
41588
41589C...Multiply by charge-squared etc. to get parton distribution.
41590 CHSQ=1./9.
41591 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41592 XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41593
41594 END
41595
41596C*********************************************************************
41597
41598*$ CREATE PHO_SASDIR.FOR
41599*COPY PHO_SASDIR
41600CDECK ID>, PHO_SASDIR
41601 SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41602C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41603C...as needed in MSbar parametrizations.
41604 SAVE
41605 DIMENSION XPGA(-6:6)
41606 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41607
41608C...Reset output.
41609 DO 100 KFL=-6,6
41610 XPGA(KFL)=0.
41611 100 CONTINUE
41612
41613C...Evaluate common x-dependent expression.
41614 XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41615 CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41616
41617C...d, u, s part by simple charge factor.
41618 XPGA(1)=(1./9.)*CGAM
41619 XPGA(2)=(4./9.)*CGAM
41620 XPGA(3)=(1./9.)*CGAM
41621
41622C...Also fill for antiquarks.
41623 DO 110 KF=1,5
41624 XPGA(-KF)=XPGA(KF)
41625 110 CONTINUE
41626
41627 END
41628
41629*$ CREATE PHO_PHGAL.FOR
41630*COPY PHO_PHGAL
41631CDECK ID>, PHO_PHGAL
41632 SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41633C***********************************************************************
41634C
41635C photon parton densities with built-in momentum sum rule and
41636C Regge-based low-x behaviour
41637C
41638C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41639C e-Print Archive: hep-ph/9711355
41640C
41641C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41642C
41643C***********************************************************************
41644 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41645 SAVE
41646
41647 PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41648 DOUBLE PRECISION
41649 & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41650 & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41651
41652 DIMENSION NA(NARG)
41653
41654 DATA ZEROD/0.D0/
41655
41656C...100 x values; in (D-4,.77) log spaced (78 points)
41657C... in (.78,.995) lineary spaced (22 points)
41658 DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41659 DATA XT/
41660 &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41661 &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41662 &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41663 &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41664 &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41665 &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41666 &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41667 &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41668 &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41669 &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41670 &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41671 &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41672 &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41673 &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41674 &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41675 &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41676 &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41677
41678C...place for DATA blocks
41679 DATA (XPV(I,1,0),I=1,100)/
41680 &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41681 &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41682 &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41683 &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41684 &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41685 &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41686 &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41687 &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41688 &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41689 &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41690 &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41691 &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41692 &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41693 &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41694 &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41695 &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41696 &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41697 DATA (XPV(I,1,1),I=1,100)/
41698 &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41699 &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41700 &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41701 &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41702 &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41703 &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41704 &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41705 &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41706 &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41707 &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41708 &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41709 &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41710 &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41711 &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41712 &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41713 &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41714 &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41715 DATA (XPV(I,1,2),I=1,100)/
41716 &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41717 &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41718 &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41719 &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41720 &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41721 &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41722 &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41723 &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41724 &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41725 &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41726 &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41727 &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41728 &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41729 &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41730 &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41731 &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41732 &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41733 DATA (XPV(I,1,3),I=1,100)/
41734 &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41735 &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41736 &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41737 &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41738 &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41739 &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41740 &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41741 &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41742 &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41743 &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41744 &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41745 &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41746 &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41747 &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41748 &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41749 &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41750 &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41751 DATA (XPV(I,1,4),I=1,100)/
41752 &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41753 &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41754 &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41755 &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41756 &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41757 &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41758 &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41759 &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41760 &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41761 &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41762 &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41763 &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41764 &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41765 &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41766 &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41767 &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41768 &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41769 DATA (XPV(I,2,0),I=1,100)/
41770 &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41771 &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41772 &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41773 &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41774 &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41775 &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41776 &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41777 &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41778 &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41779 &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41780 &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41781 &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41782 &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41783 &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41784 &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41785 &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41786 &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41787 DATA (XPV(I,2,1),I=1,100)/
41788 &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41789 &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41790 &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41791 &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41792 &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41793 &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41794 &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41795 &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41796 &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41797 &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41798 &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41799 &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41800 &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41801 &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41802 &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41803 &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41804 &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41805 DATA (XPV(I,2,2),I=1,100)/
41806 &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41807 &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41808 &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41809 &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41810 &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41811 &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41812 &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41813 &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41814 &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41815 &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41816 &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41817 &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41818 &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41819 &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41820 &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41821 &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41822 &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41823 DATA (XPV(I,2,3),I=1,100)/
41824 &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41825 &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41826 &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41827 &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41828 &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41829 &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41830 &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41831 &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41832 &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41833 &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41834 &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41835 &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41836 &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41837 &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41838 &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41839 &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41840 &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41841 DATA (XPV(I,2,4),I=1,100)/
41842 &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41843 &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41844 &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41845 &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41846 &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41847 &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41848 &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41849 &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41850 &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41851 &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41852 &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41853 &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41854 &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41855 &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41856 &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41857 &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41858 &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41859 DATA (XPV(I,3,0),I=1,100)/
41860 &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41861 &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41862 &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41863 &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41864 &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41865 &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41866 &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41867 &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41868 &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41869 &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41870 &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41871 &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41872 &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41873 &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41874 &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41875 &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41876 &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41877 DATA (XPV(I,3,1),I=1,100)/
41878 &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41879 &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41880 &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41881 &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41882 &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41883 &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41884 &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41885 &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41886 &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41887 &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41888 &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41889 &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41890 &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41891 &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41892 &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41893 &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41894 &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41895 DATA (XPV(I,3,2),I=1,100)/
41896 &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41897 &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41898 &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41899 &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41900 &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41901 &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41902 &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41903 &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41904 &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41905 &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41906 &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41907 &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41908 &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41909 &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41910 &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41911 &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41912 &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41913 DATA (XPV(I,3,3),I=1,100)/
41914 &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41915 &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41916 &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41917 &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41918 &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41919 &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41920 &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41921 &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41922 &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41923 &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41924 &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41925 &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41926 &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41927 &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41928 &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41929 &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41930 &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41931 DATA (XPV(I,3,4),I=1,100)/
41932 &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41933 &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41934 &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41935 &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41936 &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41937 &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41938 &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41939 &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41940 &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41941 &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41942 &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41943 &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41944 &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41945 &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41946 &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41947 &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41948 &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41949 DATA (XPV(I,4,0),I=1,100)/
41950 &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41951 &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41952 &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41953 &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41954 &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41955 &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41956 &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41957 &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41958 &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41959 &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41960 &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41961 &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41962 &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41963 &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41964 &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41965 &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41966 &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41967 DATA (XPV(I,4,1),I=1,100)/
41968 &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41969 &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41970 &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41971 &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41972 &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41973 &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41974 &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41975 &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41976 &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41977 &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41978 &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41979 &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41980 &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41981 &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41982 &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41983 &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41984 &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41985 DATA (XPV(I,4,2),I=1,100)/
41986 &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41987 &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41988 &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41989 &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41990 &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41991 &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41992 &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41993 &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41994 &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41995 &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41996 &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41997 &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41998 &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41999 &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
42000 &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
42001 &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
42002 &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
42003 DATA (XPV(I,4,3),I=1,100)/
42004 &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
42005 &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
42006 &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
42007 &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
42008 &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
42009 &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
42010 &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
42011 &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
42012 &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
42013 &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
42014 &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
42015 &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
42016 &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
42017 &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
42018 &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
42019 &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
42020 &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
42021 DATA (XPV(I,4,4),I=1,100)/
42022 &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
42023 &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
42024 &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
42025 &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
42026 &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
42027 &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
42028 &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
42029 &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
42030 &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
42031 &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
42032 &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
42033 &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
42034 &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
42035 &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
42036 &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
42037 &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
42038 &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
42039 DATA (XPV(I,5,0),I=1,100)/
42040 &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
42041 &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
42042 &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
42043 &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
42044 &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
42045 &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
42046 &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
42047 &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
42048 &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
42049 &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
42050 &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
42051 &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
42052 &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
42053 &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
42054 &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
42055 &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
42056 &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
42057 DATA (XPV(I,5,1),I=1,100)/
42058 &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
42059 &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
42060 &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
42061 &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
42062 &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
42063 &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
42064 &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
42065 &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
42066 &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
42067 &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
42068 &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
42069 &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
42070 &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
42071 &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
42072 &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
42073 &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
42074 &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
42075 DATA (XPV(I,5,2),I=1,100)/
42076 &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
42077 &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
42078 &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
42079 &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
42080 &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
42081 &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
42082 &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
42083 &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
42084 &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
42085 &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
42086 &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
42087 &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
42088 &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
42089 &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
42090 &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
42091 &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
42092 &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
42093 DATA (XPV(I,5,3),I=1,100)/
42094 &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
42095 &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
42096 &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
42097 &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
42098 &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
42099 &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
42100 &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
42101 &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
42102 &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
42103 &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
42104 &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
42105 &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
42106 &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
42107 &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
42108 &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
42109 &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
42110 &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
42111 DATA (XPV(I,5,4),I=1,100)/
42112 &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
42113 &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
42114 &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
42115 &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
42116 &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
42117 &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
42118 &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
42119 &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
42120 &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
42121 &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
42122 &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
42123 &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
42124 &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
42125 &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
42126 &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
42127 &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
42128 &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
42129 DATA (XPV(I,6,0),I=1,100)/
42130 &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
42131 &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
42132 &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
42133 &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
42134 &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
42135 &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
42136 &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
42137 &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
42138 &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
42139 &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
42140 &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
42141 &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
42142 &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
42143 &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
42144 &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
42145 &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
42146 &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
42147 DATA (XPV(I,6,1),I=1,100)/
42148 &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
42149 &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
42150 &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
42151 &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
42152 &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
42153 &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
42154 &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
42155 &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
42156 &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
42157 &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
42158 &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
42159 &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
42160 &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
42161 &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
42162 &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
42163 &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
42164 &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
42165 DATA (XPV(I,6,2),I=1,100)/
42166 &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
42167 &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
42168 &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
42169 &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
42170 &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
42171 &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
42172 &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
42173 &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
42174 &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
42175 &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
42176 &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
42177 &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
42178 &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
42179 &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
42180 &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
42181 &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
42182 &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
42183 DATA (XPV(I,6,3),I=1,100)/
42184 &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
42185 &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
42186 &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
42187 &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
42188 &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
42189 &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
42190 &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
42191 &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
42192 &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
42193 &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
42194 &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
42195 &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
42196 &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
42197 &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
42198 &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
42199 &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
42200 &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
42201 DATA (XPV(I,6,4),I=1,100)/
42202 &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
42203 &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
42204 &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
42205 &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
42206 &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
42207 &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
42208 &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
42209 &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
42210 &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
42211 &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
42212 &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
42213 &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
42214 &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
42215 &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
42216 &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
42217 &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
42218 &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
42219 DATA (XPV(I,7,0),I=1,100)/
42220 &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
42221 &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
42222 &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
42223 &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
42224 &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
42225 &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
42226 &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
42227 &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
42228 &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
42229 &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
42230 &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
42231 &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
42232 &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
42233 &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
42234 &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
42235 &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
42236 &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
42237 DATA (XPV(I,7,1),I=1,100)/
42238 &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
42239 &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
42240 &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
42241 &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
42242 &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
42243 &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
42244 &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
42245 &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
42246 &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
42247 &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
42248 &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
42249 &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
42250 &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
42251 &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
42252 &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
42253 &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
42254 &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
42255 DATA (XPV(I,7,2),I=1,100)/
42256 &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
42257 &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
42258 &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
42259 &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
42260 &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
42261 &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
42262 &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
42263 &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
42264 &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
42265 &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
42266 &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
42267 &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
42268 &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
42269 &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
42270 &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
42271 &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
42272 &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
42273 DATA (XPV(I,7,3),I=1,100)/
42274 &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
42275 &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
42276 &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
42277 &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
42278 &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
42279 &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
42280 &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
42281 &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
42282 &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
42283 &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
42284 &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
42285 &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
42286 &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
42287 &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
42288 &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
42289 &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
42290 &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
42291 DATA (XPV(I,7,4),I=1,100)/
42292 &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
42293 &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
42294 &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
42295 &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
42296 &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
42297 &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
42298 &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
42299 &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
42300 &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
42301 &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
42302 &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
42303 &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
42304 &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
42305 &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
42306 &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
42307 &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
42308 &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
42309
42310C..fetching pdfs
42311 DO 5 IP=-6,6
42312 XPDF(IP)=ZEROD
42313 5 CONTINUE
42314 DO 2 I=1,IX
42315 ENT(I)=LOG10(XT(I))
42316 2 CONTINUE
42317 NA(1)=IX
42318 NA(2)=IQ
42319 DO 3 I=1,IQ
42320 ENT(IX+I)=LOG10(Q2T(I))
42321 3 CONTINUE
42322 ARG(1)=LOG10(X)
42323 ARG(2)=LOG10(Q2)
42324C..various flavours (u-->2,d-->1)
42325 XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
42326 XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
42327 XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
42328 XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
42329 XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
42330 DO 21 JF=1,4
42331 XPDF(-JF)=XPDF(JF)
42332 21 CONTINUE
42333
42334 END
42335
42336*$ CREATE PHO_DBFINT.FOR
42337*COPY PHO_DBFINT
42338CDECK ID>, PHO_DBFINT
42339 DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
42340C***********************************************************************
42341C
42342C routine based on CERN library E104
42343C
42344C multi-dimensional interpolation routine, needed for PHOJET
42345C internal cross section tables and several PDF sets (GRV98 and AGL)
42346C
42347C changed to avoid recursive function calls (R.Engel, 09/98)
42348C
42349C***********************************************************************
42350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42351 SAVE
42352
42353 INTEGER NA(NARG), INDEX(32)
42354 DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
42355
42356 DATA ZEROD/0.D0/
42357 DATA ONED/1.D0/
42358
42359 DBFINT = ZEROD
42360 PHO_DBFINT = ZEROD
42361 IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
42362
42363 LMAX = 0
42364 ISTEP = 1
42365 KNOTS = 1
42366 INDEX(1) = 1
42367 WEIGHT(1) = ONED
42368 DO 100 N = 1, NARG
42369 X = ARG(N)
42370 NDIM = NA(N)
42371 LOCA = LMAX
42372 LMIN = LMAX + 1
42373 LMAX = LMAX + NDIM
42374 IF(NDIM .GT. 2) GOTO 10
42375 IF(NDIM .EQ. 1) GOTO 100
42376 H = X - ENT(LMIN)
42377 IF(H .EQ. ZEROD) GOTO 90
42378 ISHIFT = ISTEP
42379 IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
42380 ISHIFT = 0
42381 ETA = H / (ENT(LMIN+1) - ENT(LMIN))
42382 GOTO 30
42383 10 LOCB = LMAX + 1
42384 11 LOCC = (LOCA+LOCB) / 2
42385 IF(X-ENT(LOCC)) 12, 20, 13
42386 12 LOCB = LOCC
42387 GOTO 14
42388 13 LOCA = LOCC
42389 14 IF(LOCB-LOCA .GT. 1) GOTO 11
42390 LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
42391 ISHIFT = (LOCA - LMIN) * ISTEP
42392 ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
42393 GOTO 30
42394 20 ISHIFT = (LOCC - LMIN) * ISTEP
42395 21 DO 22 K = 1, KNOTS
42396 INDEX(K) = INDEX(K) + ISHIFT
42397 22 CONTINUE
42398 GOTO 90
42399 30 DO 31 K = 1, KNOTS
42400 INDEX(K) = INDEX(K) + ISHIFT
42401 INDEX(K+KNOTS) = INDEX(K) + ISTEP
42402 WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
42403 WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
42404 31 CONTINUE
42405 KNOTS = 2*KNOTS
42406 90 ISTEP = ISTEP * NDIM
42407 100 CONTINUE
42408 DO 200 K = 1, KNOTS
42409 I = INDEX(K)
42410 DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
42411 200 CONTINUE
42412
42413 PHO_DBFINT = DBFINT
42414
42415 END
42416
42417*$ CREATE PHVAL.FOR
42418*COPY PHVAL
42419CDECK ID>, PHVAL
42420 SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
42421C**********************************************************************
42422C
42423C dummy subroutine, remove to link PHOLIB
42424C
42425C**********************************************************************
42426 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42427 DIMENSION PD(-6:6)
42428 END